home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-04-25 | 92.5 KB | 3,162 lines |
- Newsgroups: comp.sources.unix
- From: voodoo@hitl.washington.edu (Geoffery Coco)
- Subject: v26i186: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part03/16
- Sender: unix-sources-moderator@vix.com
- Approved: paul@vix.com
-
- Submitted-By: voodoo@hitl.washington.edu (Geoffery Coco)
- Posting-Number: Volume 26, Issue 186
- Archive-Name: veos-2.0/part03
-
- #! /bin/sh
- # This is a shell archive. Remove anything before this line, then unpack
- # it by saving it into a file and typing "sh file". To overwrite existing
- # files, type "sh file -c". You can also feed this as standard input via
- # unshar, or by typing "sh <file", e.g.. If this archive is complete, you
- # will see the following message at the end:
- # "End of archive 3 (of 16)."
- # Contents: kernel_private/makefile kernel_private/src/fern/fgod.lsp
- # kernel_private/src/include/world.h kernel_private/src/talk/shmem.c
- # src/include/world.h src/kernel_current/fern/fgod.lsp
- # src/kernel_current/include/world.h src/kernel_current/talk/shmem.c
- # src/xlisp/xcore/c/ChangeLog src/xlisp/xcore/c/xldmem.h
- # Wrapped by vixie@efficacy.home.vix.com on Sun Apr 25 23:10:33 1993
- PATH=/bin:/usr/bin:/usr/ucb ; export PATH
- if test -f 'kernel_private/makefile' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'kernel_private/makefile'\"
- else
- echo shar: Extracting \"'kernel_private/makefile'\" \(7306 characters\)
- sed "s/^X//" >'kernel_private/makefile' <<'END_OF_FILE'
- X# *****************************************************************************
- X#
- X# VEOS 2.0 Copyright (C) 1992 Geoffrey P. Coco,
- X# Human Interface Technology Laboratory
- X#
- X# This program is free software; you use it under the terms of the
- X# VEOS LICENSE which can be found the in root of the veos directory tree.
- X#
- X# *****************************************************************************
- X
- X
- X#------------------------------------------------------------------------------
- X#
- X# VEOS makefile methodology:
- X#
- X# $(HOME) is the root veos directory.
- X# It contains all accociated source, libraries, executables and documents.
- X#
- X# $(HOME)lib/ contains public libraries for the veos kernel, xlisp, etc..
- X# $(HOME)bin/ contains public executables, like entity, testshell and xlisp.
- X# $(HOME)src/ contains public source for drivers, veos kernel, fern, etc..
- X#
- X# $(HOME)kernel_private/ is the directory reserved for the site
- X# administrator of veos. This is where all veos build commands should
- X# be issued. Build commands are performed by this makefile
- X#
- X# Notice that kernel_private/ contains the original source tree for the
- X# veos kernel and fern. When building a stable version of veos, use the
- X# 'make public' option. This command will also copy the private source
- X# and libraries to public directories $(PUB_SRC_DIR). Veos users should
- X# always link with public versions of libraries and inspect public
- X# versions of the code.
- X#
- X#------------------------------------------------------------------------------
- X
- XHOME = /home/voodoo/veos/
- XCOMMAND_DIR = ${HOME}kernel_private/
- X
- XLISP_INCLUDE_DIR = ${HOME}src/xlisp/xcore/c/
- XVEOS_INCLUDE_DIR = $(COMMAND_DIR)src/include/
- XVEOS_INCLUDE_DIRS = -I${VEOS_INCLUDE_DIR} -I${LISP_INCLUDE_DIR}
- XPUB_INCLUDE_DIR = ${HOME}src/include/
- X
- XNANCY_SRC_DIR = $(COMMAND_DIR)src/nancy/
- XSHELL_SRC_DIR = $(COMMAND_DIR)src/shell/
- XINET_SOCK_SRC_DIR = $(COMMAND_DIR)src/talk/
- XFERN_SRC_DIR = $(COMMAND_DIR)src/fern/
- XPUB_SRC_DIR = ${HOME}src/kernel_current/
- X
- XLIB_DIR = $(COMMAND_DIR)lib/
- XPUB_LIB_DIR = ${HOME}lib/
- X
- XPUB_EXEC_DIR = ${HOME}bin/
- XEXEC_DIR = $(COMMAND_DIR)bin/
- X
- XKINCLUDES = ${VEOS_INCLUDE_DIR}kernel.h \
- X ${VEOS_INCLUDE_DIR}world.h \
- X
- X#------------------------------------------------------------------------------
- X
- Xinclude $(HOME)src/machine_specific.mk
- X
- X# The machine specific file must define the following macros:
- X#
- X# CC =
- X# The c compiler and associated options.
- X# Things to include here are options for debugging,
- X# optimization, include directories, veos machine specific
- X# flags. VEOS 2.0 currently knows about -D_SG_ for Silicon
- X# Graphics, -D_DEC_ for DECStations, and -D_SUN for Sun.
- X# Do NOT use -c in this macro.
- X#
- X# AR =
- X# The library archive command and flags.
- X# Usually 'ar rcv' is sufficient
- X#
- X# UPDATE_LIB =
- X# What to do to a library after it has been archived.
- X# Usually: ranlib or touch.
- X#
- X# ASSOC_LIBS =
- X# These are extra libraries which get bound in a basic entity.
- X# The libraries for xlisp, the veos kernel, and xlisp/veos
- X# utitilities are automatically bound to the entity and do not
- X# need to be mentioned here.
- X#
- X#------------------------------------------------------------------------------
- X
- Xclean:
- X - /bin/rm -f $(SHELL_SRC_DIR)*.o
- X - /bin/rm -f $(INET_SOCK_SRC_DIR)*.o
- X - /bin/rm -f $(NANCY_SRC_DIR)*.o
- X - /bin/rm -f $(LIB_DIR)libkernel_proto.a
- X - /bin/rm -f $(LIB_DIR)libxvnative_glue_proto.a
- X - /bin/rm -f $(FERN_SRC_DIR)*.o
- X - /bin/rm -f $(LIB_DIR)libfern.a
- X
- X#------------------------------------------------------------------------------
- X
- Xpublic: entity public_kernel public_fern
- X
- Xxlisplib:
- X cd $(HOME)src/xlisp; make xlisplib
- X
- Xutils:
- X cd $(HOME)src/utils; make utils
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the kernel
- X###
- X
- Xkernel: ${LIB_DIR}libkernel_proto.a
- X
- X${LIB_DIR}libkernel_proto.a: \
- X ${SHELL_SRC_DIR}shell.o \
- X ${INET_SOCK_SRC_DIR}socket.o \
- X ${INET_SOCK_SRC_DIR}shmem.o \
- X ${INET_SOCK_SRC_DIR}talk.o \
- X ${NANCY_SRC_DIR}nancy_match.o \
- X ${NANCY_SRC_DIR}nancy_fundamental.o
- X ${AR} $@ $?
- X ${UPDATE_LIB} $@
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the native primitive library
- X###
- X
- Xnative: ${LIB_DIR}libxvnative_glue_proto.a
- X
- X${LIB_DIR}libxvnative_glue_proto.a: \
- X ${SHELL_SRC_DIR}xv_native.o \
- X ${SHELL_SRC_DIR}xv_glutils.o
- X ${AR} $@ $?
- X ${UPDATE_LIB} $@
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the talk module
- X###
- X
- Xtalk: ${INET_SOCK_SRC_DIR}socket.o ${INET_SOCK_SRC_DIR}talk.o
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the nancy module
- X###
- X
- Xnancy: ${NANCY_SRC_DIR}nancy.o ${NANCY_SRC_DIR}nancy_fundamental.o
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the shell module
- X###
- X
- Xshell: ${SHELL_SRC_DIR}shell.o
- Xmain: ${SHELL_SRC_DIR}main.o
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the fern system library
- X###
- X
- Xfern: ${LIB_DIR}libfern_proto.a
- X
- X${LIB_DIR}libfern_proto.a: ${FERN_SRC_DIR}fern.o
- X ${AR} $@ $?
- X ${UPDATE_LIB} $@
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the test entity shell
- X###
- X
- Xtestshell: ${EXEC_DIR}testshell
- X cp ${EXEC_DIR}testshell ${PUB_EXEC_DIR}testshell
- X
- X${EXEC_DIR}testshell: kernel native main fern
- X ${CC} ${SHELL_SRC_DIR}main.o \
- X -L${PUB_LIB_DIR} \
- X -L${LIB_DIR} \
- X -lxlisp \
- X -lxvnative_glue_proto \
- X -lkernel_proto \
- X -lfern_proto \
- X -lxvutils \
- X ${ASSOC_LIBS} \
- X -o $@
- X
- X
- Xentity: testshell
- X cp ${EXEC_DIR}testshell ${PUB_EXEC_DIR}entity
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### miscellaneous .o files
- X###
- X
- X.c.o:
- X ${CC} -c -o $@ $<
- X
- X.c: ${KINCLUDES}
- X
- Xzoot: zoot.o
- X ${CC} -o $@ $? -L$(LIB_DIR) -lkernel_proto
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### print the kernel
- X###
- X
- Xprint_kernel:
- X lpr ${PUB_SRC_DIR}talk/*.c
- X lpr ${PUB_SRC_DIR}nancy/*.c
- X lpr ${PUB_SRC_DIR}shell/*.c
- X lpr ${PUB_SRC_DIR}include/*.h
- X lpr $(COMMAND_DIR)makefile
- X lpr ${HOME}docs/VEOS_The_Complete_Documentation
- X lpr ${HOME}docs/VEOS_Copyright
- X
- Xprint_fern:
- X lpr ${PUB_SRC_DIR}fern/*.c
- X lpr ${PUB_SRC_DIR}fern/*.lsp
- X
- X#------------------------------------------------------------------------------
- X
- X###
- X### the public kernel
- X###
- X
- Xpublic_kernel: ${PUB_LIB_DIR}libkernel.a ${PUB_LIB_DIR}libxvnative_glue.a
- X cp ${NANCY_SRC_DIR}*.c ${PUB_SRC_DIR}nancy/.
- X cp ${SHELL_SRC_DIR}*.c ${PUB_SRC_DIR}shell/.
- X cp ${INET_SOCK_SRC_DIR}*.c ${PUB_SRC_DIR}talk/.
- X cp ${VEOS_INCLUDE_DIR}*.h ${PUB_SRC_DIR}include/.
- X cp ${VEOS_INCLUDE_DIR}world.h ${HOME}src/include/.
- X
- Xpublic_fern: ${PUB_LIB_DIR}libfern.a
- X cp ${FERN_SRC_DIR}* ${PUB_SRC_DIR}fern/.
- X
- X${PUB_LIB_DIR}libkernel.a: kernel
- X cp ${LIB_DIR}libkernel_proto.a $@
- X ${UPDATE_LIB} $@
- X
- X${PUB_LIB_DIR}libxvnative_glue.a: native
- X cp ${LIB_DIR}libxvnative_glue_proto.a $@
- X ${UPDATE_LIB} $@
- X
- X${PUB_LIB_DIR}libfern.a: fern
- X cp ${LIB_DIR}libfern_proto.a $@
- X ${UPDATE_LIB} $@
- X
- X#------------------------------------------------------------------------------
- X
- X
- END_OF_FILE
- if test 7306 -ne `wc -c <'kernel_private/makefile'`; then
- echo shar: \"'kernel_private/makefile'\" unpacked with wrong size!
- fi
- # end of 'kernel_private/makefile'
- fi
- if test -f 'kernel_private/src/fern/fgod.lsp' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'kernel_private/src/fern/fgod.lsp'\"
- else
- echo shar: Extracting \"'kernel_private/src/fern/fgod.lsp'\" \(9175 characters\)
- sed "s/^X//" >'kernel_private/src/fern/fgod.lsp' <<'END_OF_FILE'
- X;;-----------------------------------------------------------
- X;; file: fgod.lsp
- X;;
- X;; FERN is the Fractal Entity Relativity Node.
- X;; This file is the FGOD compenent of the Fern System.
- X;;
- X;; creation: February 28, 1992
- X;;
- X;; by Geoffrey P. Coco at the HITLab, Seattle
- X;;-----------------------------------------------------------
- X
- X;;-----------------------------------------------------------
- X;; Copyright (C) 1992 Geoffrey P. Coco,
- X;; Human Interface Technology Lab, Seattle
- X;;-----------------------------------------------------------
- X
- X
- X;;-----------------------------------------------------------
- X#|
- X
- XThese functions provide users of the Fern System with clean
- Xand well-defined mechanisms for directly affecting other
- Xentities. They represent the god component of the the Fern
- Xsystem (or FGOD). The FGOD primarily administrates a common
- Xprotocol for passing proactive instructions between entities.
- X
- X|#
- X;;-----------------------------------------------------------
- X;; FGOD PUBLIC FUNCTIONS
- X;;-----------------------------------------------------------
- X
- X
- X;; fgod-make-node
- X
- X;; dynamically create an entity ... somewhere.
- X;; pass which host where entity will run,
- X;; the binary executable of the entity,
- X;; and the lisp program for the entity to execute.
- X;; all these args are strings; defaults are below.
- X
- X(defun fgod-make-node (&key (run-host (aref self 0))
- X (binary "entity")
- X (program "/home/veos/lisp/tabula_rasa")
- X (display-host (aref self 0)))
- X (progn
- X
- X ;; make sure that entity can display locally
- X (cond ((equal display-host (aref self 0))
- X (cond ((not (equal run-host (aref self 0)))
- X (system (sprintf "xhost + " run-host))))))
- X
- X ;; make unix call to launch remote entity
- X (system (fgod-rsh-command run-host binary program display-host))
- X
- X ;; now, wait for reply of success
- X ;; this is handled remotely by fgod-be-node
- X (printf1 "waiting for offspring to respond...")
- X
- X ;; this var gets set by new entity via remote proc call to us -
- X ;; as part of it's startup protocol (see fgod-be-node)
- X (setq fern-descendent nil)
- X
- X (read-time)
- X (do ((reply nil) (timer 0))
- X ((cond
- X
- X ;; the entity lives !!!
- X (fern-descendent
- X (printf1 "\noffspring was: " (uid2str fern-descendent))
- X (setq reply fern-descendent)
- X (setq fern-descendent nil)
- X t)
- X
- X ;; new entity didn't respond in reasonable amount of time
- X ((> timer fgod-timeout)
- X (printf "\noffspring didn't respond.")
- X t))
- X
- X reply)
- X
- X ;; give time to persist procs and hope for reply message.
- X ;; reply is in the form: (setq fern-descendent new-entity-uid)
- X (fcon-time)
- X
- X (setq timer (+ timer (read-time)))
- X )
- X ))
- X
- X;;-----------------------------------------------------------
- X
- X;; fgod-impart
- X
- X#|
- Xarguments:
- X uid of desired entity and
- X *quoted* function call.
- X
- Xexecute remote lisp functions.
- X
- Xconsider this example of the proper way to use fgod-impart:
- X
- X (fgod-implant #("iris2" 5503) `(fe-enter ,self))
- X
- Xthis call will cause the remote entity to 'enter' your entity as a
- Xspace. this can be used for smart portals.
- X
- Xwe quote the remote function call so that the function is finally
- Xevaluated by the catcher of this message - not by the thrower.
- X
- Xnotice that the code we want to send contains a variable (i.e. self)
- Xwhich we want to evaluate *before* the message is thrown. we can use
- Xthe 'backquote-comma' syntax as shown to do this.
- X
- Xhere is another, more complex example:
- X
- X (fgod-impart #("iris2" 5503)
- X `(setq remote-var
- X (list ,(+ local-x local-y) (+ remote-x remote-y))))
- X
- Xagain, we quote the entire message with backquote. but we want to
- Xevaluate the expression (+ local-x local-y) *before* throwing, thus
- Xthe comma before this expression.
- X
- Xnotice that the second argument to setq is a call to (list ...). this
- Xis also passed on unevaluated to the catching entity. when this
- Xmessage is eventually evaluated, it will then create a list of the
- Xalready computed (+ local-x local-y) value and the result of the
- Xexpression (+ remote-x remote-y).
- X
- Xto restate, the (+ remote-x remote-y) is evaluated by the catcher of
- Xthe message. the (list ...) is so that the remote lisp will not try
- Xto evaluate (<computed-val> (+ local-x local-y)) as a function call.
- X
- XNOTE: please use this function for remote entity editing, rather than
- Xcalling vthrow yourself - in the future, this function will also throw
- Xan ancestral password.
- X|#
- X
- X
- X(defun fgod-impart (uid remote-func-call)
- X (vthrow (list uid) remote-func-call))
- X
- X;;-----------------------------------------------------------
- X
- X;; same as fgod-impart except that it holds and waits the
- X;; the result of the remote function call.
- X;; timeout is in seconds
- X
- X(defun fgod-seq-impart (uid remote-func-call)
- X (progn
- X (vthrow (list uid) `(fgod-seq-remote ,self ,remote-func-call))
- X
- X (setq fgod-seq-reply nil)
- X (read-time)
- X (do ((reply nil) (timer 0))
- X
- X ((cond
- X
- X ;; the entity responded !!!
- X (fgod-seq-reply
- X ;; the remote entity will pass back the result inside an extra list.
- X ;; this is so we can distinguish between no reponse and a response of nil.
- X (setq reply (car fgod-seq-reply))
- X (setq fgod-seq-reply nil)
- X t)
- X
- X ;; entity didn't respond in adequate time
- X ((> timer fgod-timeout)
- X t))
- X
- X reply)
- X
- X ;; give time to persist procs and hope for reply message.
- X ;; reply is in the form: (setq fgod-seq-reply data)
- X (fcon-time)
- X
- X (setq timer (+ timer (read-time)))
- X )
- X ))
- X
- X
- X;;-----------------------------------------------------------
- X
- X
- X;;-----------------------------------------------------------
- X;; FGOD PRIVATE FUNCTIONS
- X;;-----------------------------------------------------------
- X
- X(defun fgod-init ()
- X ;; try to alert creator that we made it
- X (fgod-be-node)
- X
- X (setq fgod-timeout 15)
- X )
- X
- X;;-----------------------------------------------------------
- X
- X;; generate command string to pass to unix which does:
- X;; rsh to host,
- X;; xterm with display to local screen,
- X;; and run a chosen entity with a chosen startup program.
- X
- X(defun fgod-rsh-command (run-host binary program display-host)
- X (progn
- X
- X (cond (fern-debug
- X (printf "run-host: " run-host)
- X (printf "binary: " binary)
- X (printf "program: " program)
- X (printf "display-host: " display-host)))
- X
- X (let (xterm-command
- X window-title
- X entity-command)
- X (setq
- X entity-command (sprintf
- X ;; xlisp binary to execute
- X binary
- X " "
- X ;; the ancestor bits
- X (fgod-ancestor-code)
- X " "
- X ;; the xlisp startup program
- X program
- X )
- X window-title (sprintf binary "@" run-host)
- X xterm-command (sprintf
- X ;; call xterm remotely
- X "xterm "
- X ;; xterm window coords
- X "-geometry "
- X (fgod-new-wind)
- X " "
- X ;; xwindow tricks
- X "-iconic "
- X ;; xterm window name
- X "-T "
- X window-title
- X " "
- X ;; display on chosen screen
- X (cond ((not (equal run-host display-host))
- X (sprintf
- X "-display "
- X (fgod-host-xwindow display-host)
- X " ")))
- X ;; the entity program
- X "-e "
- X entity-command))
- X
- X (cond
- X ;; local case is simple, no rsh needed
- X ((equal run-host (aref self 0))
- X (sprintf
- X ;; the remote command
- X xterm-command
- X " "
- X ;; make this a local background process
- X "&"))
- X
- X ;; remote case, rsh the entire command
- X (t
- X (sprintf "rsh "
- X ;; where to rsh
- X run-host
- X ;; don't pass this terminal's input to it.
- X " -n "
- X ;; the remote command
- X "\"" xterm-command "\" "
- X ;; make this a local background process
- X "&")))
- X )))
- X
- X;;-----------------------------------------------------------
- X
- X;; generate command string for X-window placement on screen.
- X;; with repeated calls, this produces geometry for tiled windows.
- X
- X(defun fgod-new-wind ()
- X (progn
- X (cond ((boundp 'xwindow-place)
- X (setf (nth 1 xwindow-place) (- (nth 1 xwindow-place) 25))
- X (setf (nth 3 xwindow-place) (- (nth 3 xwindow-place) 25)))
- X (t
- X (setq xwindow-place '("76x15+" 430 "+" 640))))
- X (eval `(sprintf ,@xwindow-place))))
- X
- X
- X;;-----------------------------------------------------------
- X
- X(defmacro fgod-ancestor-code ()
- X (sprintf "/home/veos/lisp/ancestors/"
- X (aref self 0) "_" (aref self 1) ".lsp "))
- X
- X(defun fgod-host-xwindow (display-host)
- X (sprintf display-host ":0.0"))
- X
- X;;-----------------------------------------------------------
- X
- X;; the remote reply handler for fgod-seq-impart
- X(defun fgod-seq-remote (sender-uid local-func-call)
- X ;; note the particular protocol, here.
- X ;; we send the reply inside an extra list.
- X ;; this is so that the remote caller (fgod-seq-impart) can
- X ;; distinguish between no response and a response of nil
- X (vthrow (list sender-uid) `(setq fgod-seq-reply '(,local-func-call))))
- X
- X;;-----------------------------------------------------------
- X
- X;; remote counterpart to fgod-make-node
- X(defun fgod-be-node ()
- X (cond ((boundp 'fern-ancestor)
- X (printf "throwing to ancestor...")
- X (print (vthrow `(,fern-ancestor) `(setq fern-descendent ,self)))
- X t)))
- X
- X;;-----------------------------------------------------------
- X
- X
- END_OF_FILE
- if test 9175 -ne `wc -c <'kernel_private/src/fern/fgod.lsp'`; then
- echo shar: \"'kernel_private/src/fern/fgod.lsp'\" unpacked with wrong size!
- fi
- # end of 'kernel_private/src/fern/fgod.lsp'
- fi
- if test -f 'kernel_private/src/include/world.h' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'kernel_private/src/include/world.h'\"
- else
- echo shar: Extracting \"'kernel_private/src/include/world.h'\" \(7962 characters\)
- sed "s/^X//" >'kernel_private/src/include/world.h' <<'END_OF_FILE'
- X/****************************************************************************************
- X * file: world.h *
- X * *
- X * May 18, 1991: any veos code - kernel or prims - should use this include. *
- X * *
- X * by Geoffrey P. Coco at the HITLab, Seattle. *
- X * *
- X ****************************************************************************************/
- X
- X/****************************************************************************************
- X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle *
- X ****************************************************************************************/
- X
- X
- X/****************************************************************************************
- X ** common includes **
- X ****************************************************************************************/
- X
- X#include <stdio.h>
- X#include <errno.h>
- X#include <string.h>
- X#include <sys/types.h>
- X#include <sys/time.h>
- X
- X/****************************************************************************************
- X ** common useful structures **
- X ****************************************************************************************/
- X
- X
- Xtypedef int TVeosErr; /* return type of all veos functions */
- X
- Xtypedef char boolean;
- X
- Xtypedef char str63[63];
- Xtypedef char str15[15];
- Xtypedef char str255[255];
- X
- X
- Xtypedef u_long TTimeStamp, *TPTimeStamp, **THTimeStamp;
- X
- Xtypedef struct {
- X union {
- X float f;
- X long l;
- X } u;
- X } TF2L;
- X
- X/****************************************************************************************
- X ** the grouple structure **
- X ****************************************************************************************/
- X
- X/** grouple element types **/
- X
- X#define GR_unspecified 0
- X
- X#define GR_grouple 1
- X#define GR_vector 2
- X#define GR_float 3
- X#define GR_int 4
- X#define GR_prim 5
- X#define GR_string 6
- X
- X#define GR_these 10
- X#define GR_theseall 11
- X#define GR_some 12
- X#define GR_any 13
- X#define GR_here 14
- X
- X#define GR_mark 15
- X#define GR_touch 16
- X
- X
- Xtypedef struct grouple *TPGrouple;
- Xtypedef struct grouple **THGrouple;
- X
- X
- Xtypedef struct {
- X int iType;
- X union {
- X char *pU;
- X
- X char *pS;
- X TPGrouple pGr;
- X
- X float fVal;
- X int iVal;
- X
- X } u;
- X
- X TTimeStamp tLastMod;
- X int iFlags;
- X
- X } TElt,
- X *TPElt,
- X **THElt;
- X
- X
- Xtypedef struct grouple {
- X int iElts;
- X TElt *pEltList;
- X
- X int iFlags;
- X
- X } TGrouple;
- X
- X/****************************************************************************************
- X ** common VEOS constants **
- X ****************************************************************************************/
- X
- X#ifndef TRUE
- X#define TRUE 1
- X#endif
- X
- X#ifndef FALSE
- X#define FALSE 0
- X#endif
- X
- X#ifndef nil
- X#define nil 0
- X#endif
- X
- X/****************************************************************************************
- X ** VEOS-wide return values **
- X ****************************************************************************************/
- X
- X#define VEOS_FAILURE -1 /* values of type TVeosErr */
- X#define VEOS_NEUTRAL 0
- X#define VEOS_SUCCESS 1
- X
- X#define VEOS_EOF -2
- X#define VEOS_MEM_ERR -3
- X#define VEOS_FILE_ERR -4
- X#define VEOS_DATA_ERR -5
- X
- X/****************************************************************************************
- X ** common Nancy constants **
- X ****************************************************************************************/
- X
- X#define NANCY_LessThan -217
- X#define NANCY_GreaterThan -218
- X#define NANCY_EndOfGrouple -220
- X
- X#define NANCY_MisplacedLeftBracket -223
- X#define NANCY_MisplacedRightBracket -222
- X#define NANCY_MissingRightBracket -224
- X
- X#define NANCY_NoTypeMatch -225
- X#define NANCY_BadType -226
- X
- X#define NANCY_MatchIncomplete -229
- X#define NANCY_MatchOne -230
- X#define NANCY_MatchMany -231
- X
- X#define NANCY_CopyMatch -232
- X#define NANCY_RemoveMatch -233
- X#define NANCY_GimmeMatch -234
- X#define NANCY_ReplaceMatch -235
- X
- X#define NANCY_NoMatch -236
- X#define NANCY_NotSupported -237
- X
- X#define NANCY_SrcTooShort -238
- X#define NANCY_PatTooShort -239
- X
- X#define NANCY_Explicit -245
- X#define NANCY_Implicit -246
- X
- X/****************************************************************************************
- X ** common Shell constants **
- X ****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************
- X ** common Talk constants **
- X ****************************************************************************************/
- X
- X#define TALK_BOGUS_FD -1 /* real file descriptors are non-neg */
- X#define TALK_BOGUS_HOST -1
- X#define TALK_BOGUS_PORT -1
- X
- X/****************************************************************************************
- X ** common useful macros **
- X ****************************************************************************************/
- X
- X
- X
- X/** SunOS requires 4th-word alignment when allocating memory on Sun 4's
- X ** but other machines must use same scheme for network compatibility.
- X ** ... lowest common denominator ...
- X **/
- X#define MEMSIZE(sz) (((sz) + 3) & 0xFFFFFFFC)
- X
- X#define MALLOC(sz) malloc(MEMSIZE(sz))
- X#define REMALLOC(ptr, sz) realloc(ptr, MEMSIZE(sz))
- X
- X#define NEWPTR(ptr, type, size) (ptr = (type) MALLOC(size))
- X#define AGAINPTR(destptr, srcptr, type, size) (destptr = (type) REMALLOC(srcptr, size))
- X
- X#define DELETE(var) free((char *) var)
- X#define DUMP(ptr) free((char *) ptr)
- X
- X
- X#define SETFLAG(flag, flagvar) flagvar |= flag
- X#define CLRFLAG(flag, flagvar) flagvar &= ~flag
- X#define TESTFLAG(flag, flagvar) ((flag & flagvar) ? TRUE : FALSE)
- X
- X#define SAVE_FLAGS(flag, save) { save = flag & NANCY_FlagMask; \
- X flag &= ~NANCY_FlagMask; }
- X
- X#define RESTORE_FLAGS(flag, save) { flag |= save; }
- X
- X
- X#define TIME_LESS_THAN(time1, time2) (time1 < time2)
- X
- X#define CATCH_TRAP(iSignal, bTrapped) \
- X if (TRAP_FLAGS & 0x00000001 << iSignal) { \
- X TRAP_FLAGS = TRAP_FLAGS & ~(0x00000001 << iSignal); \
- X TERMINATE = FALSE; \
- X bTrapped = TRUE; \
- X } \
- X else \
- X bTrapped = FALSE;
- X
- X#define NANCY_EltMarkMask 0x40000000
- X#define NANCY_EltMatchMask 0x20000000
- X#define NANCY_EltTouchMask 0x10000000
- X#define NANCY_FlagMask 0x70000000
- X
- X#define NANCY_MarkWithinMask 0x00000001
- X#define NANCY_TouchWithinMask 0x00000008
- X#define NANCY_ContentMask 0x00000002
- X#define NANCY_VectorMask 0x00000004
- X
- X#define NEW_GROUPLE(pGrouple) \
- X{ \
- X Nancy_NewGrouple(&pGrouple); \
- X }
- X
- X#define NEW_ELT(iType, pData, pElt) \
- X{ \
- X Nancy_CreateElement(pElt, iType, 0); \
- X bcopy((char *) pData, pElt->u.pU, TYPE_SIZES[iType]); \
- X }
- X
- X#define INSERT_ELT(pGrouple, pElt, iLoc) \
- X{ \
- X Nancy_NewElementsInGrouple(pGrouple, iLoc, 1, GR_unspecified, 0); \
- X pGrouple->pEltList[iLoc] = *pElt; \
- X }
- X
- X#define charsymbolp(s, ch) (symbolp(s) && \
- X getstring(getpname(s))[0] == ch && \
- X getstring(getpname(s))[1] == '\0')
- X
- X#define TIME2XELT(time, pElt) \
- X{ \
- X TF2L fTrans; \
- X fTrans.u.l = time; \
- X setflonum(pElt, fTrans.u.f); \
- X }
- X
- X
- X#define XELT2TIME(pElt, time) \
- X{ \
- X TF2L fTrans; \
- X fTrans.u.f = getflonum(pElt); \
- X time = fTrans.u.l; \
- X }
- X
- X
- X/****************************************************************************************
- X ** public globals setup by the kernel **
- X ****************************************************************************************/
- X
- X#ifdef MAIN_MODULE
- Xstr63 Veos_sUid;
- Xboolean Veos_bTerminate;
- X#else
- Xextern str63 Veos_sUid;
- Xextern boolean Veos_bTerminate;
- X#endif
- X
- X#define WHOAMI Veos_sUid
- X#define TERMINATE Veos_bTerminate
- X
- X/****************************************************************************************
- X ** C utils for prim programmers **
- X ****************************************************************************************/
- X
- X#ifdef _DEC_
- Xextern char *strdup();
- X#endif
- X
- X/****************************************************************************************
- X
- X ****************************************************************************************/
- X
- X
- END_OF_FILE
- if test 7962 -ne `wc -c <'kernel_private/src/include/world.h'`; then
- echo shar: \"'kernel_private/src/include/world.h'\" unpacked with wrong size!
- fi
- # end of 'kernel_private/src/include/world.h'
- fi
- if test -f 'kernel_private/src/talk/shmem.c' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'kernel_private/src/talk/shmem.c'\"
- else
- echo shar: Extracting \"'kernel_private/src/talk/shmem.c'\" \(8706 characters\)
- sed "s/^X//" >'kernel_private/src/talk/shmem.c' <<'END_OF_FILE'
- X/****************************************************************************************
- X * *
- X * file: ShMem.c *
- X * *
- X * April 6, 1992: The shared memory handler for the Talk module of VEOS *
- X * *
- X * by Geoffrey P. Coco at the HITLab, Seattle. *
- X * *
- X ****************************************************************************************/
- X
- X/****************************************************************************************
- X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle *
- X ****************************************************************************************/
- X
- X
- X/****************************************************************************************
- X * include the papa include file */
- X
- X#include "kernel.h"
- X#include <signal.h>
- X
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_Init()
- X{
- X TVeosErr iErr;
- X boolean bTrap;
- X str255 sSave;
- X
- X iErr = VEOS_SUCCESS;
- X
- X#ifdef _SG_
- X usconfig(CONF_INITSIZE, SHMEM_SHARED_BUF_SIZE);
- X
- X iErr = SHMEM_INIT_ERR;
- X
- X SHMEM_ARENA = usinit(SHMEM_ARENA_FILE);
- X
- X CATCH_TRAP(SIGBUS, bTrap);
- X if (bTrap || (SHMEM_ARENA == nil)) {
- X strcpy(sSave, "/bin/rm/ -f ");
- X strcat(sSave, SHMEM_ARENA_FILE);
- X system(sSave);
- X SHMEM_ARENA = usinit(SHMEM_ARENA_FILE);
- X }
- X
- X if (TALK_BUGS)
- X fprintf(stderr, "talk %s: attaching to shared memory arena %s\n",
- X WHOAMI, SHMEM_ARENA ? "was successful" : "failed");
- X
- X if (SHMEM_ARENA) {
- X
- X SHMEM_DOMAIN = usgetinfo(SHMEM_ARENA);
- X
- X if (TALK_BUGS)
- X fprintf(stderr, "talk %s: veos communication domain %s\n",
- X WHOAMI, SHMEM_DOMAIN ? "found" : "not found, creating one...");
- X
- X if (SHMEM_DOMAIN == nil) {
- X /** first entity on this machine,
- X ** initialize the shmem domain
- X **/
- X
- X chmod(SHMEM_ARENA_FILE, 0777);
- X
- X iErr = VEOS_MEM_ERR;
- X SHMEM_DOMAIN = usmalloc(sizeof(TShDomainRec), SHMEM_ARENA);
- X
- X if (SHMEM_DOMAIN) {
- X
- X SHMEM_DOMAIN->pChainSem = usnewsema(SHMEM_ARENA, 1);
- X SHMEM_DOMAIN->pChannelChain = nil;
- X
- X usputinfo(SHMEM_ARENA, SHMEM_DOMAIN);
- X }
- X }
- X
- X
- X if (SHMEM_DOMAIN) {
- X
- X if (TALK_BUGS)
- X fprintf(stderr, "talk %s: creating memory listen channel...\n", WHOAMI);
- X
- X iErr = VEOS_MEM_ERR;
- X SHMEM_CHANNEL = usmalloc(sizeof(TSharedRec), SHMEM_ARENA);
- X
- X if (SHMEM_CHANNEL) {
- X
- X SHMEM_CHANNEL->iPort = IDENT_ADDR.iPort;
- X SHMEM_CHANNEL->pSem = usnewsema(SHMEM_ARENA, 1);
- X SHMEM_CHANNEL->pAvail = &SHMEM_CHANNEL->pBuffer[0];
- X SHMEM_CHANNEL->pEnd = &SHMEM_CHANNEL->pBuffer[0] + SHMEM_RW_BUF_SIZE;
- X
- X
- X /** link new entity channel into shared domain record **/
- X
- X uspsema(SHMEM_DOMAIN->pChainSem);
- X
- X SHMEM_CHANNEL->pNext = SHMEM_DOMAIN->pChannelChain;
- X SHMEM_DOMAIN->pChannelChain = SHMEM_CHANNEL;
- X
- X usvsema(SHMEM_DOMAIN->pChainSem);
- X
- X iErr = VEOS_SUCCESS;
- X }
- X }
- X }
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_Init */
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_Close()
- X{
- X TVeosErr iErr;
- X boolean bLast = FALSE;
- X THSharedRec hFinger;
- X TPSharedRec pSaveLink;
- X TPSemaphor pSaveSem;
- X
- X iErr = VEOS_SUCCESS;
- X
- X#ifdef _SG_
- X /** stop others from looking at the channel chain **/
- X uspsema(SHMEM_DOMAIN->pChainSem);
- X
- X /** this channel is about to vanish
- X ** wait for others to finish looking at this channel
- X **/
- X pSaveSem = SHMEM_CHANNEL->pSem;
- X uspsema(pSaveSem);
- X
- X /** find our channel in the domain channel chain,
- X ** remove it, recoupling the links, and free the memory
- X **/
- X hFinger = &SHMEM_DOMAIN->pChannelChain;
- X while (*hFinger) {
- X
- X if (*hFinger == SHMEM_CHANNEL) {
- X pSaveLink = (*hFinger)->pNext;
- X usfree(*hFinger, SHMEM_ARENA);
- X *hFinger = pSaveLink;
- X break;
- X }
- X hFinger = &(*hFinger)->pNext;
- X }
- X
- X /** release and remove the channel semaphore **/
- X usvsema(pSaveSem);
- X usfreesema(pSaveSem, SHMEM_ARENA);
- X
- X if (SHMEM_DOMAIN->pChannelChain == nil)
- X bLast = TRUE;
- X
- X /** allow others to cleanly find no channel **/
- X usvsema(SHMEM_DOMAIN->pChainSem);
- X
- X if (bLast) {
- X usfreesema(SHMEM_DOMAIN->pChainSem, SHMEM_ARENA);
- X usfree(SHMEM_DOMAIN, SHMEM_ARENA);
- X unlink(SHMEM_ARENA_FILE);
- X }
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_Close */
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_WriteMessages(pSpeakNode)
- X TPSpeakNode pSpeakNode;
- X{
- X TVeosErr iErr = VEOS_FAILURE;
- X int iLen;
- X TPMessageNode pSaveLink;
- X char *sMessage;
- X TPSharedRec pWriteChannel;
- X
- X
- X#ifdef _SG_
- X iErr = ShMem_FindChannel(pSpeakNode->destRec.iPort, &pWriteChannel);
- X
- X if (iErr != VEOS_SUCCESS)
- X iErr = TALK_CONN_CLOSED;
- X
- X else {
- X
- X /** dispatch message sending...
- X ** oldest jobs first to enforce sequencing
- X **/
- X
- X do {
- X /** attempt to transmit oldest message **/
- X
- X sMessage = pSpeakNode->pMessageQ->sMessage;
- X iLen = pSpeakNode->pMessageQ->iMsgLen;
- X
- X
- X
- X /** wait for exclusive rights to memory channel **/
- X
- X uspsema(pWriteChannel->pSem);
- X
- X
- X
- X /** check for available space in buffer **/
- X#ifndef OPTIMAL
- X if (TALK_BUGS) {
- X fprintf(stderr, "speak %s: buffer has %d bytes avail.\n",
- X WHOAMI, pWriteChannel->pEnd - pWriteChannel->pAvail);
- X }
- X#endif
- X if (pWriteChannel->pAvail + iLen > pWriteChannel->pEnd)
- X iErr = SHMEM_FULL;
- X
- X else {
- X /** write the message **/
- X
- X bcopy(sMessage, pWriteChannel->pAvail, iLen);
- X pWriteChannel->pAvail += iLen;
- X#ifndef OPTIMAL
- X if (TALK_BUGS)
- X fprintf(stderr, "speak %s: wrote message, length: %d\n",
- X WHOAMI, iLen);
- X#endif
- X }
- X
- X /** give up rights to memory channel **/
- X
- X usvsema(pWriteChannel->pSem);
- X
- X
- X if (iErr == VEOS_SUCCESS) {
- X
- X /** dequeue this message from connection record **/
- X
- X DUMP(sMessage);
- X
- X
- X pSaveLink = pSpeakNode->pMessageQ->pLink;
- X Shell_ReturnBlock(pSpeakNode->pMessageQ,
- X sizeof(TMessageNode), "message node");
- X pSpeakNode->pMessageQ = pSaveLink;
- X }
- X
- X } while (pSpeakNode->pMessageQ && iErr == VEOS_SUCCESS);
- X }
- X
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_WriteMessages */
- X/****************************************************************************************/
- X
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_GatherMessages()
- X{
- X TVeosErr iErr = VEOS_SUCCESS;
- X char *pFinger;
- X TMsgRec pbMsg;
- X
- X#ifdef _SG_
- X uspsema(SHMEM_CHANNEL->pSem);
- X
- X /** check for any data in buffer **/
- X if (SHMEM_CHANNEL->pAvail > SHMEM_CHANNEL->pBuffer) {
- X
- X pFinger = SHMEM_CHANNEL->pBuffer;
- X while (pFinger < SHMEM_CHANNEL->pAvail) {
- X
- X pbMsg.iLen = ((int *) pFinger)[0];
- X pFinger += 4;
- X pbMsg.sMessage = pFinger;
- X
- X (*TALK_MSG_FUNC) (&pbMsg);
- X
- X pFinger += pbMsg.iLen;
- X }
- X
- X /** mark buffer empty again **/
- X SHMEM_CHANNEL->pAvail = SHMEM_CHANNEL->pBuffer;
- X }
- X
- X usvsema(SHMEM_CHANNEL->pSem);
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_GatherMessages */
- X/****************************************************************************************/
- X
- X
- X
- X
- X/****************************************************************************************/
- Xboolean ShMem_CanShareMem(pUid)
- X TPUid pUid;
- X{
- X boolean bSharedMem = FALSE;
- X
- X#ifdef _SG_
- X if (pUid->lHost == IDENT_ADDR.lHost &&
- X pUid->iPort != IDENT_ADDR.iPort)
- X bSharedMem = TRUE;
- X#endif
- X
- X return(bSharedMem);
- X
- X } /* ShMem_CanShareMem */
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_FindChannel(iPort, hChannel)
- X int iPort;
- X THSharedRec hChannel;
- X{
- X TVeosErr iErr = VEOS_FAILURE;
- X TPSharedRec pFinger;
- X
- X *hChannel = nil;
- X
- X#ifdef _SG_
- X /** find channel for this destination **/
- X
- X uspsema(SHMEM_DOMAIN->pChainSem);
- X
- X pFinger = SHMEM_DOMAIN->pChannelChain;
- X
- X while (pFinger) {
- X if (pFinger->iPort != iPort)
- X pFinger = pFinger->pNext;
- X else {
- X *hChannel = pFinger;
- X iErr = VEOS_SUCCESS;
- X break;
- X }
- X }
- X
- X usvsema(SHMEM_DOMAIN->pChainSem);
- X#endif
- X
- X return(iErr);
- X }
- X/****************************************************************************************/
- END_OF_FILE
- if test 8706 -ne `wc -c <'kernel_private/src/talk/shmem.c'`; then
- echo shar: \"'kernel_private/src/talk/shmem.c'\" unpacked with wrong size!
- fi
- # end of 'kernel_private/src/talk/shmem.c'
- fi
- if test -f 'src/include/world.h' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/include/world.h'\"
- else
- echo shar: Extracting \"'src/include/world.h'\" \(7962 characters\)
- sed "s/^X//" >'src/include/world.h' <<'END_OF_FILE'
- X/****************************************************************************************
- X * file: world.h *
- X * *
- X * May 18, 1991: any veos code - kernel or prims - should use this include. *
- X * *
- X * by Geoffrey P. Coco at the HITLab, Seattle. *
- X * *
- X ****************************************************************************************/
- X
- X/****************************************************************************************
- X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle *
- X ****************************************************************************************/
- X
- X
- X/****************************************************************************************
- X ** common includes **
- X ****************************************************************************************/
- X
- X#include <stdio.h>
- X#include <errno.h>
- X#include <string.h>
- X#include <sys/types.h>
- X#include <sys/time.h>
- X
- X/****************************************************************************************
- X ** common useful structures **
- X ****************************************************************************************/
- X
- X
- Xtypedef int TVeosErr; /* return type of all veos functions */
- X
- Xtypedef char boolean;
- X
- Xtypedef char str63[63];
- Xtypedef char str15[15];
- Xtypedef char str255[255];
- X
- X
- Xtypedef u_long TTimeStamp, *TPTimeStamp, **THTimeStamp;
- X
- Xtypedef struct {
- X union {
- X float f;
- X long l;
- X } u;
- X } TF2L;
- X
- X/****************************************************************************************
- X ** the grouple structure **
- X ****************************************************************************************/
- X
- X/** grouple element types **/
- X
- X#define GR_unspecified 0
- X
- X#define GR_grouple 1
- X#define GR_vector 2
- X#define GR_float 3
- X#define GR_int 4
- X#define GR_prim 5
- X#define GR_string 6
- X
- X#define GR_these 10
- X#define GR_theseall 11
- X#define GR_some 12
- X#define GR_any 13
- X#define GR_here 14
- X
- X#define GR_mark 15
- X#define GR_touch 16
- X
- X
- Xtypedef struct grouple *TPGrouple;
- Xtypedef struct grouple **THGrouple;
- X
- X
- Xtypedef struct {
- X int iType;
- X union {
- X char *pU;
- X
- X char *pS;
- X TPGrouple pGr;
- X
- X float fVal;
- X int iVal;
- X
- X } u;
- X
- X TTimeStamp tLastMod;
- X int iFlags;
- X
- X } TElt,
- X *TPElt,
- X **THElt;
- X
- X
- Xtypedef struct grouple {
- X int iElts;
- X TElt *pEltList;
- X
- X int iFlags;
- X
- X } TGrouple;
- X
- X/****************************************************************************************
- X ** common VEOS constants **
- X ****************************************************************************************/
- X
- X#ifndef TRUE
- X#define TRUE 1
- X#endif
- X
- X#ifndef FALSE
- X#define FALSE 0
- X#endif
- X
- X#ifndef nil
- X#define nil 0
- X#endif
- X
- X/****************************************************************************************
- X ** VEOS-wide return values **
- X ****************************************************************************************/
- X
- X#define VEOS_FAILURE -1 /* values of type TVeosErr */
- X#define VEOS_NEUTRAL 0
- X#define VEOS_SUCCESS 1
- X
- X#define VEOS_EOF -2
- X#define VEOS_MEM_ERR -3
- X#define VEOS_FILE_ERR -4
- X#define VEOS_DATA_ERR -5
- X
- X/****************************************************************************************
- X ** common Nancy constants **
- X ****************************************************************************************/
- X
- X#define NANCY_LessThan -217
- X#define NANCY_GreaterThan -218
- X#define NANCY_EndOfGrouple -220
- X
- X#define NANCY_MisplacedLeftBracket -223
- X#define NANCY_MisplacedRightBracket -222
- X#define NANCY_MissingRightBracket -224
- X
- X#define NANCY_NoTypeMatch -225
- X#define NANCY_BadType -226
- X
- X#define NANCY_MatchIncomplete -229
- X#define NANCY_MatchOne -230
- X#define NANCY_MatchMany -231
- X
- X#define NANCY_CopyMatch -232
- X#define NANCY_RemoveMatch -233
- X#define NANCY_GimmeMatch -234
- X#define NANCY_ReplaceMatch -235
- X
- X#define NANCY_NoMatch -236
- X#define NANCY_NotSupported -237
- X
- X#define NANCY_SrcTooShort -238
- X#define NANCY_PatTooShort -239
- X
- X#define NANCY_Explicit -245
- X#define NANCY_Implicit -246
- X
- X/****************************************************************************************
- X ** common Shell constants **
- X ****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************
- X ** common Talk constants **
- X ****************************************************************************************/
- X
- X#define TALK_BOGUS_FD -1 /* real file descriptors are non-neg */
- X#define TALK_BOGUS_HOST -1
- X#define TALK_BOGUS_PORT -1
- X
- X/****************************************************************************************
- X ** common useful macros **
- X ****************************************************************************************/
- X
- X
- X
- X/** SunOS requires 4th-word alignment when allocating memory on Sun 4's
- X ** but other machines must use same scheme for network compatibility.
- X ** ... lowest common denominator ...
- X **/
- X#define MEMSIZE(sz) (((sz) + 3) & 0xFFFFFFFC)
- X
- X#define MALLOC(sz) malloc(MEMSIZE(sz))
- X#define REMALLOC(ptr, sz) realloc(ptr, MEMSIZE(sz))
- X
- X#define NEWPTR(ptr, type, size) (ptr = (type) MALLOC(size))
- X#define AGAINPTR(destptr, srcptr, type, size) (destptr = (type) REMALLOC(srcptr, size))
- X
- X#define DELETE(var) free((char *) var)
- X#define DUMP(ptr) free((char *) ptr)
- X
- X
- X#define SETFLAG(flag, flagvar) flagvar |= flag
- X#define CLRFLAG(flag, flagvar) flagvar &= ~flag
- X#define TESTFLAG(flag, flagvar) ((flag & flagvar) ? TRUE : FALSE)
- X
- X#define SAVE_FLAGS(flag, save) { save = flag & NANCY_FlagMask; \
- X flag &= ~NANCY_FlagMask; }
- X
- X#define RESTORE_FLAGS(flag, save) { flag |= save; }
- X
- X
- X#define TIME_LESS_THAN(time1, time2) (time1 < time2)
- X
- X#define CATCH_TRAP(iSignal, bTrapped) \
- X if (TRAP_FLAGS & 0x00000001 << iSignal) { \
- X TRAP_FLAGS = TRAP_FLAGS & ~(0x00000001 << iSignal); \
- X TERMINATE = FALSE; \
- X bTrapped = TRUE; \
- X } \
- X else \
- X bTrapped = FALSE;
- X
- X#define NANCY_EltMarkMask 0x40000000
- X#define NANCY_EltMatchMask 0x20000000
- X#define NANCY_EltTouchMask 0x10000000
- X#define NANCY_FlagMask 0x70000000
- X
- X#define NANCY_MarkWithinMask 0x00000001
- X#define NANCY_TouchWithinMask 0x00000008
- X#define NANCY_ContentMask 0x00000002
- X#define NANCY_VectorMask 0x00000004
- X
- X#define NEW_GROUPLE(pGrouple) \
- X{ \
- X Nancy_NewGrouple(&pGrouple); \
- X }
- X
- X#define NEW_ELT(iType, pData, pElt) \
- X{ \
- X Nancy_CreateElement(pElt, iType, 0); \
- X bcopy((char *) pData, pElt->u.pU, TYPE_SIZES[iType]); \
- X }
- X
- X#define INSERT_ELT(pGrouple, pElt, iLoc) \
- X{ \
- X Nancy_NewElementsInGrouple(pGrouple, iLoc, 1, GR_unspecified, 0); \
- X pGrouple->pEltList[iLoc] = *pElt; \
- X }
- X
- X#define charsymbolp(s, ch) (symbolp(s) && \
- X getstring(getpname(s))[0] == ch && \
- X getstring(getpname(s))[1] == '\0')
- X
- X#define TIME2XELT(time, pElt) \
- X{ \
- X TF2L fTrans; \
- X fTrans.u.l = time; \
- X setflonum(pElt, fTrans.u.f); \
- X }
- X
- X
- X#define XELT2TIME(pElt, time) \
- X{ \
- X TF2L fTrans; \
- X fTrans.u.f = getflonum(pElt); \
- X time = fTrans.u.l; \
- X }
- X
- X
- X/****************************************************************************************
- X ** public globals setup by the kernel **
- X ****************************************************************************************/
- X
- X#ifdef MAIN_MODULE
- Xstr63 Veos_sUid;
- Xboolean Veos_bTerminate;
- X#else
- Xextern str63 Veos_sUid;
- Xextern boolean Veos_bTerminate;
- X#endif
- X
- X#define WHOAMI Veos_sUid
- X#define TERMINATE Veos_bTerminate
- X
- X/****************************************************************************************
- X ** C utils for prim programmers **
- X ****************************************************************************************/
- X
- X#ifdef _DEC_
- Xextern char *strdup();
- X#endif
- X
- X/****************************************************************************************
- X
- X ****************************************************************************************/
- X
- X
- END_OF_FILE
- if test 7962 -ne `wc -c <'src/include/world.h'`; then
- echo shar: \"'src/include/world.h'\" unpacked with wrong size!
- fi
- # end of 'src/include/world.h'
- fi
- if test -f 'src/kernel_current/fern/fgod.lsp' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/kernel_current/fern/fgod.lsp'\"
- else
- echo shar: Extracting \"'src/kernel_current/fern/fgod.lsp'\" \(9175 characters\)
- sed "s/^X//" >'src/kernel_current/fern/fgod.lsp' <<'END_OF_FILE'
- X;;-----------------------------------------------------------
- X;; file: fgod.lsp
- X;;
- X;; FERN is the Fractal Entity Relativity Node.
- X;; This file is the FGOD compenent of the Fern System.
- X;;
- X;; creation: February 28, 1992
- X;;
- X;; by Geoffrey P. Coco at the HITLab, Seattle
- X;;-----------------------------------------------------------
- X
- X;;-----------------------------------------------------------
- X;; Copyright (C) 1992 Geoffrey P. Coco,
- X;; Human Interface Technology Lab, Seattle
- X;;-----------------------------------------------------------
- X
- X
- X;;-----------------------------------------------------------
- X#|
- X
- XThese functions provide users of the Fern System with clean
- Xand well-defined mechanisms for directly affecting other
- Xentities. They represent the god component of the the Fern
- Xsystem (or FGOD). The FGOD primarily administrates a common
- Xprotocol for passing proactive instructions between entities.
- X
- X|#
- X;;-----------------------------------------------------------
- X;; FGOD PUBLIC FUNCTIONS
- X;;-----------------------------------------------------------
- X
- X
- X;; fgod-make-node
- X
- X;; dynamically create an entity ... somewhere.
- X;; pass which host where entity will run,
- X;; the binary executable of the entity,
- X;; and the lisp program for the entity to execute.
- X;; all these args are strings; defaults are below.
- X
- X(defun fgod-make-node (&key (run-host (aref self 0))
- X (binary "entity")
- X (program "/home/veos/lisp/tabula_rasa")
- X (display-host (aref self 0)))
- X (progn
- X
- X ;; make sure that entity can display locally
- X (cond ((equal display-host (aref self 0))
- X (cond ((not (equal run-host (aref self 0)))
- X (system (sprintf "xhost + " run-host))))))
- X
- X ;; make unix call to launch remote entity
- X (system (fgod-rsh-command run-host binary program display-host))
- X
- X ;; now, wait for reply of success
- X ;; this is handled remotely by fgod-be-node
- X (printf1 "waiting for offspring to respond...")
- X
- X ;; this var gets set by new entity via remote proc call to us -
- X ;; as part of it's startup protocol (see fgod-be-node)
- X (setq fern-descendent nil)
- X
- X (read-time)
- X (do ((reply nil) (timer 0))
- X ((cond
- X
- X ;; the entity lives !!!
- X (fern-descendent
- X (printf1 "\noffspring was: " (uid2str fern-descendent))
- X (setq reply fern-descendent)
- X (setq fern-descendent nil)
- X t)
- X
- X ;; new entity didn't respond in reasonable amount of time
- X ((> timer fgod-timeout)
- X (printf "\noffspring didn't respond.")
- X t))
- X
- X reply)
- X
- X ;; give time to persist procs and hope for reply message.
- X ;; reply is in the form: (setq fern-descendent new-entity-uid)
- X (fcon-time)
- X
- X (setq timer (+ timer (read-time)))
- X )
- X ))
- X
- X;;-----------------------------------------------------------
- X
- X;; fgod-impart
- X
- X#|
- Xarguments:
- X uid of desired entity and
- X *quoted* function call.
- X
- Xexecute remote lisp functions.
- X
- Xconsider this example of the proper way to use fgod-impart:
- X
- X (fgod-implant #("iris2" 5503) `(fe-enter ,self))
- X
- Xthis call will cause the remote entity to 'enter' your entity as a
- Xspace. this can be used for smart portals.
- X
- Xwe quote the remote function call so that the function is finally
- Xevaluated by the catcher of this message - not by the thrower.
- X
- Xnotice that the code we want to send contains a variable (i.e. self)
- Xwhich we want to evaluate *before* the message is thrown. we can use
- Xthe 'backquote-comma' syntax as shown to do this.
- X
- Xhere is another, more complex example:
- X
- X (fgod-impart #("iris2" 5503)
- X `(setq remote-var
- X (list ,(+ local-x local-y) (+ remote-x remote-y))))
- X
- Xagain, we quote the entire message with backquote. but we want to
- Xevaluate the expression (+ local-x local-y) *before* throwing, thus
- Xthe comma before this expression.
- X
- Xnotice that the second argument to setq is a call to (list ...). this
- Xis also passed on unevaluated to the catching entity. when this
- Xmessage is eventually evaluated, it will then create a list of the
- Xalready computed (+ local-x local-y) value and the result of the
- Xexpression (+ remote-x remote-y).
- X
- Xto restate, the (+ remote-x remote-y) is evaluated by the catcher of
- Xthe message. the (list ...) is so that the remote lisp will not try
- Xto evaluate (<computed-val> (+ local-x local-y)) as a function call.
- X
- XNOTE: please use this function for remote entity editing, rather than
- Xcalling vthrow yourself - in the future, this function will also throw
- Xan ancestral password.
- X|#
- X
- X
- X(defun fgod-impart (uid remote-func-call)
- X (vthrow (list uid) remote-func-call))
- X
- X;;-----------------------------------------------------------
- X
- X;; same as fgod-impart except that it holds and waits the
- X;; the result of the remote function call.
- X;; timeout is in seconds
- X
- X(defun fgod-seq-impart (uid remote-func-call)
- X (progn
- X (vthrow (list uid) `(fgod-seq-remote ,self ,remote-func-call))
- X
- X (setq fgod-seq-reply nil)
- X (read-time)
- X (do ((reply nil) (timer 0))
- X
- X ((cond
- X
- X ;; the entity responded !!!
- X (fgod-seq-reply
- X ;; the remote entity will pass back the result inside an extra list.
- X ;; this is so we can distinguish between no reponse and a response of nil.
- X (setq reply (car fgod-seq-reply))
- X (setq fgod-seq-reply nil)
- X t)
- X
- X ;; entity didn't respond in adequate time
- X ((> timer fgod-timeout)
- X t))
- X
- X reply)
- X
- X ;; give time to persist procs and hope for reply message.
- X ;; reply is in the form: (setq fgod-seq-reply data)
- X (fcon-time)
- X
- X (setq timer (+ timer (read-time)))
- X )
- X ))
- X
- X
- X;;-----------------------------------------------------------
- X
- X
- X;;-----------------------------------------------------------
- X;; FGOD PRIVATE FUNCTIONS
- X;;-----------------------------------------------------------
- X
- X(defun fgod-init ()
- X ;; try to alert creator that we made it
- X (fgod-be-node)
- X
- X (setq fgod-timeout 15)
- X )
- X
- X;;-----------------------------------------------------------
- X
- X;; generate command string to pass to unix which does:
- X;; rsh to host,
- X;; xterm with display to local screen,
- X;; and run a chosen entity with a chosen startup program.
- X
- X(defun fgod-rsh-command (run-host binary program display-host)
- X (progn
- X
- X (cond (fern-debug
- X (printf "run-host: " run-host)
- X (printf "binary: " binary)
- X (printf "program: " program)
- X (printf "display-host: " display-host)))
- X
- X (let (xterm-command
- X window-title
- X entity-command)
- X (setq
- X entity-command (sprintf
- X ;; xlisp binary to execute
- X binary
- X " "
- X ;; the ancestor bits
- X (fgod-ancestor-code)
- X " "
- X ;; the xlisp startup program
- X program
- X )
- X window-title (sprintf binary "@" run-host)
- X xterm-command (sprintf
- X ;; call xterm remotely
- X "xterm "
- X ;; xterm window coords
- X "-geometry "
- X (fgod-new-wind)
- X " "
- X ;; xwindow tricks
- X "-iconic "
- X ;; xterm window name
- X "-T "
- X window-title
- X " "
- X ;; display on chosen screen
- X (cond ((not (equal run-host display-host))
- X (sprintf
- X "-display "
- X (fgod-host-xwindow display-host)
- X " ")))
- X ;; the entity program
- X "-e "
- X entity-command))
- X
- X (cond
- X ;; local case is simple, no rsh needed
- X ((equal run-host (aref self 0))
- X (sprintf
- X ;; the remote command
- X xterm-command
- X " "
- X ;; make this a local background process
- X "&"))
- X
- X ;; remote case, rsh the entire command
- X (t
- X (sprintf "rsh "
- X ;; where to rsh
- X run-host
- X ;; don't pass this terminal's input to it.
- X " -n "
- X ;; the remote command
- X "\"" xterm-command "\" "
- X ;; make this a local background process
- X "&")))
- X )))
- X
- X;;-----------------------------------------------------------
- X
- X;; generate command string for X-window placement on screen.
- X;; with repeated calls, this produces geometry for tiled windows.
- X
- X(defun fgod-new-wind ()
- X (progn
- X (cond ((boundp 'xwindow-place)
- X (setf (nth 1 xwindow-place) (- (nth 1 xwindow-place) 25))
- X (setf (nth 3 xwindow-place) (- (nth 3 xwindow-place) 25)))
- X (t
- X (setq xwindow-place '("76x15+" 430 "+" 640))))
- X (eval `(sprintf ,@xwindow-place))))
- X
- X
- X;;-----------------------------------------------------------
- X
- X(defmacro fgod-ancestor-code ()
- X (sprintf "/home/veos/lisp/ancestors/"
- X (aref self 0) "_" (aref self 1) ".lsp "))
- X
- X(defun fgod-host-xwindow (display-host)
- X (sprintf display-host ":0.0"))
- X
- X;;-----------------------------------------------------------
- X
- X;; the remote reply handler for fgod-seq-impart
- X(defun fgod-seq-remote (sender-uid local-func-call)
- X ;; note the particular protocol, here.
- X ;; we send the reply inside an extra list.
- X ;; this is so that the remote caller (fgod-seq-impart) can
- X ;; distinguish between no response and a response of nil
- X (vthrow (list sender-uid) `(setq fgod-seq-reply '(,local-func-call))))
- X
- X;;-----------------------------------------------------------
- X
- X;; remote counterpart to fgod-make-node
- X(defun fgod-be-node ()
- X (cond ((boundp 'fern-ancestor)
- X (printf "throwing to ancestor...")
- X (print (vthrow `(,fern-ancestor) `(setq fern-descendent ,self)))
- X t)))
- X
- X;;-----------------------------------------------------------
- X
- X
- END_OF_FILE
- if test 9175 -ne `wc -c <'src/kernel_current/fern/fgod.lsp'`; then
- echo shar: \"'src/kernel_current/fern/fgod.lsp'\" unpacked with wrong size!
- fi
- # end of 'src/kernel_current/fern/fgod.lsp'
- fi
- if test -f 'src/kernel_current/include/world.h' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/kernel_current/include/world.h'\"
- else
- echo shar: Extracting \"'src/kernel_current/include/world.h'\" \(7962 characters\)
- sed "s/^X//" >'src/kernel_current/include/world.h' <<'END_OF_FILE'
- X/****************************************************************************************
- X * file: world.h *
- X * *
- X * May 18, 1991: any veos code - kernel or prims - should use this include. *
- X * *
- X * by Geoffrey P. Coco at the HITLab, Seattle. *
- X * *
- X ****************************************************************************************/
- X
- X/****************************************************************************************
- X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle *
- X ****************************************************************************************/
- X
- X
- X/****************************************************************************************
- X ** common includes **
- X ****************************************************************************************/
- X
- X#include <stdio.h>
- X#include <errno.h>
- X#include <string.h>
- X#include <sys/types.h>
- X#include <sys/time.h>
- X
- X/****************************************************************************************
- X ** common useful structures **
- X ****************************************************************************************/
- X
- X
- Xtypedef int TVeosErr; /* return type of all veos functions */
- X
- Xtypedef char boolean;
- X
- Xtypedef char str63[63];
- Xtypedef char str15[15];
- Xtypedef char str255[255];
- X
- X
- Xtypedef u_long TTimeStamp, *TPTimeStamp, **THTimeStamp;
- X
- Xtypedef struct {
- X union {
- X float f;
- X long l;
- X } u;
- X } TF2L;
- X
- X/****************************************************************************************
- X ** the grouple structure **
- X ****************************************************************************************/
- X
- X/** grouple element types **/
- X
- X#define GR_unspecified 0
- X
- X#define GR_grouple 1
- X#define GR_vector 2
- X#define GR_float 3
- X#define GR_int 4
- X#define GR_prim 5
- X#define GR_string 6
- X
- X#define GR_these 10
- X#define GR_theseall 11
- X#define GR_some 12
- X#define GR_any 13
- X#define GR_here 14
- X
- X#define GR_mark 15
- X#define GR_touch 16
- X
- X
- Xtypedef struct grouple *TPGrouple;
- Xtypedef struct grouple **THGrouple;
- X
- X
- Xtypedef struct {
- X int iType;
- X union {
- X char *pU;
- X
- X char *pS;
- X TPGrouple pGr;
- X
- X float fVal;
- X int iVal;
- X
- X } u;
- X
- X TTimeStamp tLastMod;
- X int iFlags;
- X
- X } TElt,
- X *TPElt,
- X **THElt;
- X
- X
- Xtypedef struct grouple {
- X int iElts;
- X TElt *pEltList;
- X
- X int iFlags;
- X
- X } TGrouple;
- X
- X/****************************************************************************************
- X ** common VEOS constants **
- X ****************************************************************************************/
- X
- X#ifndef TRUE
- X#define TRUE 1
- X#endif
- X
- X#ifndef FALSE
- X#define FALSE 0
- X#endif
- X
- X#ifndef nil
- X#define nil 0
- X#endif
- X
- X/****************************************************************************************
- X ** VEOS-wide return values **
- X ****************************************************************************************/
- X
- X#define VEOS_FAILURE -1 /* values of type TVeosErr */
- X#define VEOS_NEUTRAL 0
- X#define VEOS_SUCCESS 1
- X
- X#define VEOS_EOF -2
- X#define VEOS_MEM_ERR -3
- X#define VEOS_FILE_ERR -4
- X#define VEOS_DATA_ERR -5
- X
- X/****************************************************************************************
- X ** common Nancy constants **
- X ****************************************************************************************/
- X
- X#define NANCY_LessThan -217
- X#define NANCY_GreaterThan -218
- X#define NANCY_EndOfGrouple -220
- X
- X#define NANCY_MisplacedLeftBracket -223
- X#define NANCY_MisplacedRightBracket -222
- X#define NANCY_MissingRightBracket -224
- X
- X#define NANCY_NoTypeMatch -225
- X#define NANCY_BadType -226
- X
- X#define NANCY_MatchIncomplete -229
- X#define NANCY_MatchOne -230
- X#define NANCY_MatchMany -231
- X
- X#define NANCY_CopyMatch -232
- X#define NANCY_RemoveMatch -233
- X#define NANCY_GimmeMatch -234
- X#define NANCY_ReplaceMatch -235
- X
- X#define NANCY_NoMatch -236
- X#define NANCY_NotSupported -237
- X
- X#define NANCY_SrcTooShort -238
- X#define NANCY_PatTooShort -239
- X
- X#define NANCY_Explicit -245
- X#define NANCY_Implicit -246
- X
- X/****************************************************************************************
- X ** common Shell constants **
- X ****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************
- X ** common Talk constants **
- X ****************************************************************************************/
- X
- X#define TALK_BOGUS_FD -1 /* real file descriptors are non-neg */
- X#define TALK_BOGUS_HOST -1
- X#define TALK_BOGUS_PORT -1
- X
- X/****************************************************************************************
- X ** common useful macros **
- X ****************************************************************************************/
- X
- X
- X
- X/** SunOS requires 4th-word alignment when allocating memory on Sun 4's
- X ** but other machines must use same scheme for network compatibility.
- X ** ... lowest common denominator ...
- X **/
- X#define MEMSIZE(sz) (((sz) + 3) & 0xFFFFFFFC)
- X
- X#define MALLOC(sz) malloc(MEMSIZE(sz))
- X#define REMALLOC(ptr, sz) realloc(ptr, MEMSIZE(sz))
- X
- X#define NEWPTR(ptr, type, size) (ptr = (type) MALLOC(size))
- X#define AGAINPTR(destptr, srcptr, type, size) (destptr = (type) REMALLOC(srcptr, size))
- X
- X#define DELETE(var) free((char *) var)
- X#define DUMP(ptr) free((char *) ptr)
- X
- X
- X#define SETFLAG(flag, flagvar) flagvar |= flag
- X#define CLRFLAG(flag, flagvar) flagvar &= ~flag
- X#define TESTFLAG(flag, flagvar) ((flag & flagvar) ? TRUE : FALSE)
- X
- X#define SAVE_FLAGS(flag, save) { save = flag & NANCY_FlagMask; \
- X flag &= ~NANCY_FlagMask; }
- X
- X#define RESTORE_FLAGS(flag, save) { flag |= save; }
- X
- X
- X#define TIME_LESS_THAN(time1, time2) (time1 < time2)
- X
- X#define CATCH_TRAP(iSignal, bTrapped) \
- X if (TRAP_FLAGS & 0x00000001 << iSignal) { \
- X TRAP_FLAGS = TRAP_FLAGS & ~(0x00000001 << iSignal); \
- X TERMINATE = FALSE; \
- X bTrapped = TRUE; \
- X } \
- X else \
- X bTrapped = FALSE;
- X
- X#define NANCY_EltMarkMask 0x40000000
- X#define NANCY_EltMatchMask 0x20000000
- X#define NANCY_EltTouchMask 0x10000000
- X#define NANCY_FlagMask 0x70000000
- X
- X#define NANCY_MarkWithinMask 0x00000001
- X#define NANCY_TouchWithinMask 0x00000008
- X#define NANCY_ContentMask 0x00000002
- X#define NANCY_VectorMask 0x00000004
- X
- X#define NEW_GROUPLE(pGrouple) \
- X{ \
- X Nancy_NewGrouple(&pGrouple); \
- X }
- X
- X#define NEW_ELT(iType, pData, pElt) \
- X{ \
- X Nancy_CreateElement(pElt, iType, 0); \
- X bcopy((char *) pData, pElt->u.pU, TYPE_SIZES[iType]); \
- X }
- X
- X#define INSERT_ELT(pGrouple, pElt, iLoc) \
- X{ \
- X Nancy_NewElementsInGrouple(pGrouple, iLoc, 1, GR_unspecified, 0); \
- X pGrouple->pEltList[iLoc] = *pElt; \
- X }
- X
- X#define charsymbolp(s, ch) (symbolp(s) && \
- X getstring(getpname(s))[0] == ch && \
- X getstring(getpname(s))[1] == '\0')
- X
- X#define TIME2XELT(time, pElt) \
- X{ \
- X TF2L fTrans; \
- X fTrans.u.l = time; \
- X setflonum(pElt, fTrans.u.f); \
- X }
- X
- X
- X#define XELT2TIME(pElt, time) \
- X{ \
- X TF2L fTrans; \
- X fTrans.u.f = getflonum(pElt); \
- X time = fTrans.u.l; \
- X }
- X
- X
- X/****************************************************************************************
- X ** public globals setup by the kernel **
- X ****************************************************************************************/
- X
- X#ifdef MAIN_MODULE
- Xstr63 Veos_sUid;
- Xboolean Veos_bTerminate;
- X#else
- Xextern str63 Veos_sUid;
- Xextern boolean Veos_bTerminate;
- X#endif
- X
- X#define WHOAMI Veos_sUid
- X#define TERMINATE Veos_bTerminate
- X
- X/****************************************************************************************
- X ** C utils for prim programmers **
- X ****************************************************************************************/
- X
- X#ifdef _DEC_
- Xextern char *strdup();
- X#endif
- X
- X/****************************************************************************************
- X
- X ****************************************************************************************/
- X
- X
- END_OF_FILE
- if test 7962 -ne `wc -c <'src/kernel_current/include/world.h'`; then
- echo shar: \"'src/kernel_current/include/world.h'\" unpacked with wrong size!
- fi
- # end of 'src/kernel_current/include/world.h'
- fi
- if test -f 'src/kernel_current/talk/shmem.c' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/kernel_current/talk/shmem.c'\"
- else
- echo shar: Extracting \"'src/kernel_current/talk/shmem.c'\" \(8706 characters\)
- sed "s/^X//" >'src/kernel_current/talk/shmem.c' <<'END_OF_FILE'
- X/****************************************************************************************
- X * *
- X * file: ShMem.c *
- X * *
- X * April 6, 1992: The shared memory handler for the Talk module of VEOS *
- X * *
- X * by Geoffrey P. Coco at the HITLab, Seattle. *
- X * *
- X ****************************************************************************************/
- X
- X/****************************************************************************************
- X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle *
- X ****************************************************************************************/
- X
- X
- X/****************************************************************************************
- X * include the papa include file */
- X
- X#include "kernel.h"
- X#include <signal.h>
- X
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_Init()
- X{
- X TVeosErr iErr;
- X boolean bTrap;
- X str255 sSave;
- X
- X iErr = VEOS_SUCCESS;
- X
- X#ifdef _SG_
- X usconfig(CONF_INITSIZE, SHMEM_SHARED_BUF_SIZE);
- X
- X iErr = SHMEM_INIT_ERR;
- X
- X SHMEM_ARENA = usinit(SHMEM_ARENA_FILE);
- X
- X CATCH_TRAP(SIGBUS, bTrap);
- X if (bTrap || (SHMEM_ARENA == nil)) {
- X strcpy(sSave, "/bin/rm/ -f ");
- X strcat(sSave, SHMEM_ARENA_FILE);
- X system(sSave);
- X SHMEM_ARENA = usinit(SHMEM_ARENA_FILE);
- X }
- X
- X if (TALK_BUGS)
- X fprintf(stderr, "talk %s: attaching to shared memory arena %s\n",
- X WHOAMI, SHMEM_ARENA ? "was successful" : "failed");
- X
- X if (SHMEM_ARENA) {
- X
- X SHMEM_DOMAIN = usgetinfo(SHMEM_ARENA);
- X
- X if (TALK_BUGS)
- X fprintf(stderr, "talk %s: veos communication domain %s\n",
- X WHOAMI, SHMEM_DOMAIN ? "found" : "not found, creating one...");
- X
- X if (SHMEM_DOMAIN == nil) {
- X /** first entity on this machine,
- X ** initialize the shmem domain
- X **/
- X
- X chmod(SHMEM_ARENA_FILE, 0777);
- X
- X iErr = VEOS_MEM_ERR;
- X SHMEM_DOMAIN = usmalloc(sizeof(TShDomainRec), SHMEM_ARENA);
- X
- X if (SHMEM_DOMAIN) {
- X
- X SHMEM_DOMAIN->pChainSem = usnewsema(SHMEM_ARENA, 1);
- X SHMEM_DOMAIN->pChannelChain = nil;
- X
- X usputinfo(SHMEM_ARENA, SHMEM_DOMAIN);
- X }
- X }
- X
- X
- X if (SHMEM_DOMAIN) {
- X
- X if (TALK_BUGS)
- X fprintf(stderr, "talk %s: creating memory listen channel...\n", WHOAMI);
- X
- X iErr = VEOS_MEM_ERR;
- X SHMEM_CHANNEL = usmalloc(sizeof(TSharedRec), SHMEM_ARENA);
- X
- X if (SHMEM_CHANNEL) {
- X
- X SHMEM_CHANNEL->iPort = IDENT_ADDR.iPort;
- X SHMEM_CHANNEL->pSem = usnewsema(SHMEM_ARENA, 1);
- X SHMEM_CHANNEL->pAvail = &SHMEM_CHANNEL->pBuffer[0];
- X SHMEM_CHANNEL->pEnd = &SHMEM_CHANNEL->pBuffer[0] + SHMEM_RW_BUF_SIZE;
- X
- X
- X /** link new entity channel into shared domain record **/
- X
- X uspsema(SHMEM_DOMAIN->pChainSem);
- X
- X SHMEM_CHANNEL->pNext = SHMEM_DOMAIN->pChannelChain;
- X SHMEM_DOMAIN->pChannelChain = SHMEM_CHANNEL;
- X
- X usvsema(SHMEM_DOMAIN->pChainSem);
- X
- X iErr = VEOS_SUCCESS;
- X }
- X }
- X }
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_Init */
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_Close()
- X{
- X TVeosErr iErr;
- X boolean bLast = FALSE;
- X THSharedRec hFinger;
- X TPSharedRec pSaveLink;
- X TPSemaphor pSaveSem;
- X
- X iErr = VEOS_SUCCESS;
- X
- X#ifdef _SG_
- X /** stop others from looking at the channel chain **/
- X uspsema(SHMEM_DOMAIN->pChainSem);
- X
- X /** this channel is about to vanish
- X ** wait for others to finish looking at this channel
- X **/
- X pSaveSem = SHMEM_CHANNEL->pSem;
- X uspsema(pSaveSem);
- X
- X /** find our channel in the domain channel chain,
- X ** remove it, recoupling the links, and free the memory
- X **/
- X hFinger = &SHMEM_DOMAIN->pChannelChain;
- X while (*hFinger) {
- X
- X if (*hFinger == SHMEM_CHANNEL) {
- X pSaveLink = (*hFinger)->pNext;
- X usfree(*hFinger, SHMEM_ARENA);
- X *hFinger = pSaveLink;
- X break;
- X }
- X hFinger = &(*hFinger)->pNext;
- X }
- X
- X /** release and remove the channel semaphore **/
- X usvsema(pSaveSem);
- X usfreesema(pSaveSem, SHMEM_ARENA);
- X
- X if (SHMEM_DOMAIN->pChannelChain == nil)
- X bLast = TRUE;
- X
- X /** allow others to cleanly find no channel **/
- X usvsema(SHMEM_DOMAIN->pChainSem);
- X
- X if (bLast) {
- X usfreesema(SHMEM_DOMAIN->pChainSem, SHMEM_ARENA);
- X usfree(SHMEM_DOMAIN, SHMEM_ARENA);
- X unlink(SHMEM_ARENA_FILE);
- X }
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_Close */
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_WriteMessages(pSpeakNode)
- X TPSpeakNode pSpeakNode;
- X{
- X TVeosErr iErr = VEOS_FAILURE;
- X int iLen;
- X TPMessageNode pSaveLink;
- X char *sMessage;
- X TPSharedRec pWriteChannel;
- X
- X
- X#ifdef _SG_
- X iErr = ShMem_FindChannel(pSpeakNode->destRec.iPort, &pWriteChannel);
- X
- X if (iErr != VEOS_SUCCESS)
- X iErr = TALK_CONN_CLOSED;
- X
- X else {
- X
- X /** dispatch message sending...
- X ** oldest jobs first to enforce sequencing
- X **/
- X
- X do {
- X /** attempt to transmit oldest message **/
- X
- X sMessage = pSpeakNode->pMessageQ->sMessage;
- X iLen = pSpeakNode->pMessageQ->iMsgLen;
- X
- X
- X
- X /** wait for exclusive rights to memory channel **/
- X
- X uspsema(pWriteChannel->pSem);
- X
- X
- X
- X /** check for available space in buffer **/
- X#ifndef OPTIMAL
- X if (TALK_BUGS) {
- X fprintf(stderr, "speak %s: buffer has %d bytes avail.\n",
- X WHOAMI, pWriteChannel->pEnd - pWriteChannel->pAvail);
- X }
- X#endif
- X if (pWriteChannel->pAvail + iLen > pWriteChannel->pEnd)
- X iErr = SHMEM_FULL;
- X
- X else {
- X /** write the message **/
- X
- X bcopy(sMessage, pWriteChannel->pAvail, iLen);
- X pWriteChannel->pAvail += iLen;
- X#ifndef OPTIMAL
- X if (TALK_BUGS)
- X fprintf(stderr, "speak %s: wrote message, length: %d\n",
- X WHOAMI, iLen);
- X#endif
- X }
- X
- X /** give up rights to memory channel **/
- X
- X usvsema(pWriteChannel->pSem);
- X
- X
- X if (iErr == VEOS_SUCCESS) {
- X
- X /** dequeue this message from connection record **/
- X
- X DUMP(sMessage);
- X
- X
- X pSaveLink = pSpeakNode->pMessageQ->pLink;
- X Shell_ReturnBlock(pSpeakNode->pMessageQ,
- X sizeof(TMessageNode), "message node");
- X pSpeakNode->pMessageQ = pSaveLink;
- X }
- X
- X } while (pSpeakNode->pMessageQ && iErr == VEOS_SUCCESS);
- X }
- X
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_WriteMessages */
- X/****************************************************************************************/
- X
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_GatherMessages()
- X{
- X TVeosErr iErr = VEOS_SUCCESS;
- X char *pFinger;
- X TMsgRec pbMsg;
- X
- X#ifdef _SG_
- X uspsema(SHMEM_CHANNEL->pSem);
- X
- X /** check for any data in buffer **/
- X if (SHMEM_CHANNEL->pAvail > SHMEM_CHANNEL->pBuffer) {
- X
- X pFinger = SHMEM_CHANNEL->pBuffer;
- X while (pFinger < SHMEM_CHANNEL->pAvail) {
- X
- X pbMsg.iLen = ((int *) pFinger)[0];
- X pFinger += 4;
- X pbMsg.sMessage = pFinger;
- X
- X (*TALK_MSG_FUNC) (&pbMsg);
- X
- X pFinger += pbMsg.iLen;
- X }
- X
- X /** mark buffer empty again **/
- X SHMEM_CHANNEL->pAvail = SHMEM_CHANNEL->pBuffer;
- X }
- X
- X usvsema(SHMEM_CHANNEL->pSem);
- X#endif
- X
- X return(iErr);
- X
- X } /* ShMem_GatherMessages */
- X/****************************************************************************************/
- X
- X
- X
- X
- X/****************************************************************************************/
- Xboolean ShMem_CanShareMem(pUid)
- X TPUid pUid;
- X{
- X boolean bSharedMem = FALSE;
- X
- X#ifdef _SG_
- X if (pUid->lHost == IDENT_ADDR.lHost &&
- X pUid->iPort != IDENT_ADDR.iPort)
- X bSharedMem = TRUE;
- X#endif
- X
- X return(bSharedMem);
- X
- X } /* ShMem_CanShareMem */
- X/****************************************************************************************/
- X
- X
- X
- X/****************************************************************************************/
- XTVeosErr ShMem_FindChannel(iPort, hChannel)
- X int iPort;
- X THSharedRec hChannel;
- X{
- X TVeosErr iErr = VEOS_FAILURE;
- X TPSharedRec pFinger;
- X
- X *hChannel = nil;
- X
- X#ifdef _SG_
- X /** find channel for this destination **/
- X
- X uspsema(SHMEM_DOMAIN->pChainSem);
- X
- X pFinger = SHMEM_DOMAIN->pChannelChain;
- X
- X while (pFinger) {
- X if (pFinger->iPort != iPort)
- X pFinger = pFinger->pNext;
- X else {
- X *hChannel = pFinger;
- X iErr = VEOS_SUCCESS;
- X break;
- X }
- X }
- X
- X usvsema(SHMEM_DOMAIN->pChainSem);
- X#endif
- X
- X return(iErr);
- X }
- X/****************************************************************************************/
- END_OF_FILE
- if test 8706 -ne `wc -c <'src/kernel_current/talk/shmem.c'`; then
- echo shar: \"'src/kernel_current/talk/shmem.c'\" unpacked with wrong size!
- fi
- # end of 'src/kernel_current/talk/shmem.c'
- fi
- if test -f 'src/xlisp/xcore/c/ChangeLog' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/ChangeLog'\"
- else
- echo shar: Extracting \"'src/xlisp/xcore/c/ChangeLog'\" \(8739 characters\)
- sed "s/^X//" >'src/xlisp/xcore/c/ChangeLog' <<'END_OF_FILE'
- XWed Feb 12 14:32:10 1992 Andrew MacDonald (awm at hitl.washington.edu)
- X
- X * added vector case to equal primative.
- X
- XAny Jan XX XX:XX:XX 1992 Voodoo (voodoo at hitl.washington.edu)
- X
- X * setup xlisp as a library. an optional software tool.
- X rather than the mandatory command module.
- X * removed main from xlisp. xlisp entry now called xmain().
- X * xmain.c contains the func xmain which acts just like the old main.
- X the differenc is that now xlisp is compiled once as a library
- X and linked to many software tools with respective mains.
- X * added xlfinit() which sets up the xlisp function table.
- X it places the tabel in the heap rather than in global stack space.
- X * also, user defined lisp functions are included at runtime rather
- X than at compile time. again, xlisp does not need to be recompiled
- X to link with other software tools - even if there are user defined
- X xlisp functions.
- X
- XSun Jun 16 13:57:05 1991 Jeff Prothero (jsp at glia)
- X
- X * xlobj.c xsendmsg0/2/3() created.
- X
- XSat Jun 15 22:18:25 1991 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * xlobj.c xsendmsg1() created.
- X
- XThu Jan 17 12:30:00 1991 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * xldmem.c:gc() bugfix: Bind s_gchook to NIL while
- X evaluating hook fn. (This fix courtesy Tom Almy.)
- X
- X * xldmem.c:gc() bugfix: Do
- X if (nfree < (long)anodes) addseg();
- X in gc() before *GC-HOOK* code, instead of in findmem().
- X Eliminate findmem(), which no longer serves any purpose.
- X
- X * xlinit.c:xlsymbols() bugfix: Do
- X "setvalue(s_gchook,NIL);" *immediately* after
- X "s_gchook = xlenter("*GC-HOOK*");"
- X
- X
- XFri Dec 14 11:23:07 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * Renamed ~/modules.h to ~/xmodules.h, adopting a uniform
- X convention that the xlisp-interface files in a module have
- X names starting with 'x' -- and the normal C files (useful
- X even in the absence of xlisp) do not.
- X
- XThu Dec 13 00:02:11 1990 Jeff Prothero (jsp at glia)
- X
- X * Split MODULE_XLFTAB_C_FUNTAB
- X into MODULE_XLFTAB_C_FUNTAB_S
- X and MODULE_XLFTAB_C_FUNTAB_F,
- X to reduce future problems porting modules to a
- X mooted xscheme-derived xlisp core.
- X
- XWed Dec 12 23:02:52 1990 Jeff Prothero (jsp at glia)
- X
- X * Renamed ~/xcore/src/xlhybrid.h to ~/modules.h.
- X * Renamed ~/xcore/src/hybrid.h to ~/xcore/doc/mymodule.h.
- X * Renamed ~/xcore/src/gobject.[ch] to ~/gobject/src/gobject.[ch].
- X * Moved ~/xcore/test/gobject.lsp to ~/gobject/test/gobject.lsp.
- X
- XTue Dec 4 12:18:19 1990 Jeff Prothero (jsp at glia)
- X
- X * Added xlbadinit for bad initializer lists.
- X
- XWed Nov 28 13:13:27 1990 Jeff Prothero (jsp at glia)
- X
- X * xlobj.c:sendmsg() renamed to x_sendmsg() to eliminate conflict with
- X unix-socket sendmsg() fn, added xsendmsg() fn for hybrid classes
- X to call.
- X
- X * xlobj.c "class" renamed to "cls_class".
- X xlobj.c "object" renamed to "cls_object".
- X xlobj.c now exports s_self, k_new, k_isnew, cls_class and
- X cls_object, for benefit of hybrid classes which want to,
- X say, send a k_new message to cls_class.
- X
- XMon Nov 26 15:32:58 1990 Jeff Prothero (jsp at glia)
- X
- X * Killed 'LOCAL' on xlobj.c:getivcnt(), for gobject.c:gobshowI().
- X
- X * Moved #defines for MESSAGES,IVARS,CVARS,CVALS,
- X SUPERCLASS,IVARCNT,IVARTOTAL from xlobj.c to xlisp.h,
- X so hybrid classes can access them easily.
- X
- XFri Nov 23 12:58:49 1990 Jeff Prothero (jsp at glia)
- X
- X * More hooks added, to (almost) eliminate GOBJECT-specific
- X code from the core xlisp fileset:
- X MODULE_XLOBJ_C_XLOINIT,
- X MODULE_XLOBJ_C_GLOBALS,
- X MODULE_XLOBJ_C_CLNEW,
- X MODULE_XLOBJ_C_OBSYMBOLS
- X
- X * Renamed xlclass.c to xlhybrid.h
- X
- XThu Nov 22 16:31:11 1990 Jeff Prothero (jsp at glia)
- X
- X * Created xlftab.c:funtab_offset().
- X
- XTue Nov 20 11:42:48 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * Per Niels Mayer suggestion, adopted a more systematic
- X patch-point naming convention:
- X
- X DECLARING_PRIMITIVE_FUNCTIONS -> MODULE_XLFTAB_C_GLOBALS
- X NAMING_PRIMITIVE_FUNCTIONS -> MODULE_XLFTAB_C_FUNTAB
- X START_OF_WORLD_INITIALIZATION -> MODULE_XLINIT_C_XLINIT
- X END_OF_WORLD_WRAPUP -> MODULE_XLISP_C_WRAPUP
- X XLISP_H_MACROS -> MODULE_XLISP_H_GLOBALS
- X XLDMEM_H_MACROS -> MODULE_XLDMEM_H_GLOBALS
- X XLDMEM_H_EXTERNS -> (combined with above)
- X XLDMEM_H_NODE_NINFO -> MODULE_XLDMEM_H_NINFO
- X REPLACING_BREAKLOOP -> MODULE_XLDBUG_C_BREAKLOOP_REPLACEMENT
- X XLDMEM_C_CVFUNS -> MODULE_XLDMEM_C_GLOBALS
- X XLDMEM_C_MARKING_OBJECTS -> MODULE_XLDMEM_C_GC
- X XLDMEM_C_MARKING_NEW_NODE_TYPES -> MODULE_XLDMEM_C_MARK
- X XLDMEM_C_FREEING_NEW_NODE_TYPES -> MODULE_XLDMEM_C_SWEEP
- X XLDMEM_C_GC_INITIALIZATION -> MODULE_XLDMEM_C_XLMINIT
- X XLGLOB_C_VARS -> MODULE_XLGLOB_C_GLOBALS
- X XLIMAGE_C_WRITING_VECTOR -> MODULE_XLIMAGE_C_XLISAVE
- X XLIMAGE_C_READING_VECTOR -> MODULE_XLIMAGE_C_XLIRESTORE
- X XLIMAGE_C_FREEING_VECTOR -> MODULE_XLIMAGE_C_FREEIMAGE
- X XLINIT_C_VARS -> MODULE_XLINIT_C_GLOBALS
- X XLINIT_C_SYMBOLS -> MODULE_XLINIT_C_XLSYMBOLS
- X XLPRIN_C_EXTERNS -> MODULE_XLPRIN_C_GLOBALS
- X XLPRIN_C_PRINTING_NEW_NODE_TYPES-> MODULE_XLPRIN_C_XLPRINT
- X XLSYS_C_EXTERNS -> MODULE_XLSYS_C_GLOBALS
- X XLSYS_C_RETURNING_TYPE_SYMBOL -> MODULE_XLSYS_C_XTYPE
- X
- X
- XMon Nov 19 15:23:33 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * Added GETENV primitive: xosenvget() in unixstuff, line in xlftab.c.
- X
- XSun Nov 18 13:23:07 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * Added PROVIDE_GOBJECT. (Objects with LVAL vector and byte vector.)
- X This required minor patches to xlisp.h, xldmem.h, xlftab.c
- X xlobj.c and xwinterp.h, all marked with "#ifdef PROVIDE_GOBJECT".
- X (Also required gobject.h, a new hybrid-class file, and
- X gobject.c, with support function.)
- X
- XSat Nov 17 12:24:04 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * Collected the old "#ifdef WINTERP" patches in xwinterp.h
- X
- X * hybrid.h file documenting use of below.
- X
- X * xlclass.c support for hybrid classes:
- X DECLARING_PRIMITIVE_FUNCTIONS "#include" in xlftab.c
- X NAMING_PRIMITIVE_FUNCTIONS "#include" in xlftab.c:funtab[]
- X START_OF_WORLD_INITIALIZATION "#include" in xlinit.c:xlinit()
- X END_OF_WORLD_WRAPUP "#include" in xlisp.c:wrapup()
- X XLISP_H_MACROS "#include" in xlisp.h
- X XLDMEM_H_MACROS "#include" in xldmem.h
- X XLDMEM_H_NODE_NINFO "#include" in xldmem.h ninfo union
- X XLDMEM_H_EXTERNS "#include" in xldmem.h
- X REPLACING_BREAKLOOP "#include" in xldbug.c
- X XLDMEM_C_CVFUNS "#include" in xldmem.c
- X XLDMEM_C_MARKING_OBJECTS "#include" in xldmem.c:gc()
- X XLDMEM_C_MARKING_NEW_NODE_TYPES "#include" in xldmem.c:mark()
- X XLDMEM_C_FREEING_NEW_NODE_TYPES "#include" in xldmem.c:sweep()
- X XLDMEM_C_GC_INITIALIZATION "#include" in xldmem.c:xlminit()
- X XLGLOB_C_VARS "#include" in xlglob.c
- X XLIMAGE_C_WRITING_VECTOR "#include" in xlimage.c:xlisave()
- X XLIMAGE_C_READING_VECTOR "#include" in xlimage.c:xlirestore()
- X XLIMAGE_C_FREEING_VECTOR "#include" in xlimage.c:freeimage()
- X XLINIT_C_VARS "#include" in xlinit.c
- X XLINIT_C_SYMBOLS "#include" in xlinit.c:xlsymbols()
- X XLPRIN_C_EXTERNS "#include" in xlprin.c
- X XLPRIN_C_PRINTING_NEW_NODE_TYPES"#include" in xlprin.c:xlprint()
- X XLSYS_C_EXTERNS "#include" in xlsys.c
- X XLSYS_C_RETURNING_TYPE_SYMBOL "#include" in xlsys.c:xtype()
- X
- XFri Nov 16 11:06:08 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * Have xldmem.c:xlminit() check that NULL==0, since newvector() &tc
- X depend on this.
- X
- XThu Nov 15 21:08:20 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * xlread.c:pname(): Changed xlerror("zero length name");
- X to xlfail( "zero length name");
- X
- XSat Nov 10 00:09:23 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * xleval.c:xlevalenv() is never called. #ifdef'ed out.
- X
- X * xlisp.h defines TRUE and FALSE only if undefined.
- X
- X * xlftab.c: xbisubr(),xbifsubr() don't exist, deleted them.
- X
- XFri Nov 9 15:16:03 1990 Jeff Prothero (jsp at glia.biostr.washington.edu)
- X
- X * unixstuff.c, xlisp.c: renamed oserror() to xoserror to avoid
- X conflict with system SGI unix oserror fn.
- X
- X * unixstuff.c/osrand() had "&" where "%" was intended.
- X
- END_OF_FILE
- if test 8739 -ne `wc -c <'src/xlisp/xcore/c/ChangeLog'`; then
- echo shar: \"'src/xlisp/xcore/c/ChangeLog'\" unpacked with wrong size!
- fi
- # end of 'src/xlisp/xcore/c/ChangeLog'
- fi
- if test -f 'src/xlisp/xcore/c/xldmem.h' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xldmem.h'\"
- else
- echo shar: Extracting \"'src/xlisp/xcore/c/xldmem.h'\" \(9492 characters\)
- sed "s/^X//" >'src/xlisp/xcore/c/xldmem.h' <<'END_OF_FILE'
- X/* -*-C-*-
- X********************************************************************************
- X*
- X* File: xldmem.h
- X* RCS: $Header: xldmem.h,v 1.7 89/11/25 05:22:56 mayer Exp $
- X* Description: dynamic memory definitions
- X* Author: David Michael Betz; Niels Mayer
- X* Created:
- X* Modified: Sat Nov 25 05:22:46 1989 (Niels Mayer) mayer@hplnpm
- X* Language: C
- X* Package: N/A
- X* Status: X11r4 contrib tape release
- X*
- X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
- X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
- X*
- X* Permission to use, copy, modify, distribute, and sell this software and its
- X* documentation for any purpose is hereby granted without fee, provided that
- X* the above copyright notice appear in all copies and that both that
- X* copyright notice and this permission notice appear in supporting
- X* documentation, and that the name of Hewlett-Packard and David Betz not be
- X* used in advertising or publicity pertaining to distribution of the software
- X* without specific, written prior permission. Hewlett-Packard and David Betz
- X* make no representations about the suitability of this software for any
- X* purpose. It is provided "as is" without express or implied warranty.
- X*
- X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
- X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
- X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
- X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
- X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
- X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
- X* PERFORMANCE OF THIS SOFTWARE.
- X*
- X* See ./winterp/COPYRIGHT for information on contacting the authors.
- X*
- X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
- X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
- X*
- X********************************************************************************
- X*/
- X
- X
- X/* small fixnum range */
- X#define SFIXMIN (-128)
- X#define SFIXMAX 255
- X#define SFIXSIZE 384
- X
- X/* character range */
- X#define CHARMIN 0
- X#define CHARMAX 255
- X#define CHARSIZE 256
- X
- X/* new node access macros */
- X#define ntype(x) ((x)->n_type)
- X
- X/* cons access macros */
- X#define car(x) ((x)->n_car)
- X#define cdr(x) ((x)->n_cdr)
- X#define rplaca(x,y) ((x)->n_car = (y))
- X#define rplacd(x,y) ((x)->n_cdr = (y))
- X
- X/* symbol access macros */
- X#define getvalue(x) ((x)->n_vdata[0])
- X#define setvalue(x,v) ((x)->n_vdata[0] = (v))
- X#define getfunction(x) ((x)->n_vdata[1])
- X#define setfunction(x,v) ((x)->n_vdata[1] = (v))
- X#define getplist(x) ((x)->n_vdata[2])
- X#define setplist(x,v) ((x)->n_vdata[2] = (v))
- X#define getpname(x) ((x)->n_vdata[3])
- X#define setpname(x,v) ((x)->n_vdata[3] = (v))
- X#define SYMSIZE 4
- X
- X/* closure access macros */
- X#define getname(x) ((x)->n_vdata[0])
- X#define setname(x,v) ((x)->n_vdata[0] = (v))
- X#define gettype(x) ((x)->n_vdata[1])
- X#define settype(x,v) ((x)->n_vdata[1] = (v))
- X#define getargs(x) ((x)->n_vdata[2])
- X#define setargs(x,v) ((x)->n_vdata[2] = (v))
- X#define getoargs(x) ((x)->n_vdata[3])
- X#define setoargs(x,v) ((x)->n_vdata[3] = (v))
- X#define getrest(x) ((x)->n_vdata[4])
- X#define setrest(x,v) ((x)->n_vdata[4] = (v))
- X#define getkargs(x) ((x)->n_vdata[5])
- X#define setkargs(x,v) ((x)->n_vdata[5] = (v))
- X#define getaargs(x) ((x)->n_vdata[6])
- X#define setaargs(x,v) ((x)->n_vdata[6] = (v))
- X#define getbody(x) ((x)->n_vdata[7])
- X#define setbody(x,v) ((x)->n_vdata[7] = (v))
- X#define xlgetenv(x) ((x)->n_vdata[8])
- X#define setenv(x,v) ((x)->n_vdata[8] = (v))
- X#define getfenv(x) ((x)->n_vdata[9])
- X#define setfenv(x,v) ((x)->n_vdata[9] = (v))
- X#define getlambda(x) ((x)->n_vdata[10])
- X#define setlambda(x,v) ((x)->n_vdata[10] = (v))
- X#define CLOSIZE 11
- X
- X/* vector access macros */
- X#define getsz(x) ((x)->n_vsize)
- X#define getelement(x,i) ((x)->n_vdata[i])
- X#define setelement(x,i,v) ((x)->n_vdata[i] = (v))
- X
- X/* object access macros */
- X#define getclass(x) ((x)->n_vdata[0])
- X#define getivar(x,i) ((x)->n_vdata[i+1])
- X#define setivar(x,i,v) ((x)->n_vdata[i+1] = (v))
- X
- X/* subr/fsubr access macros */
- X#define getsubr(x) ((x)->n_subr)
- X#define getoffset(x) ((x)->n_offset)
- X
- X/* fixnum/flonum/char access macros */
- X#define getfixnum(x) ((x)->n_fixnum)
- X#define getflonum(x) ((x)->n_flonum)
- X#define setflonum(x, val) (x)->n_flonum = (val) /* Voodoo */
- X#define getchcode(x) ((x)->n_chcode)
- X
- X/* string access macros */
- X#define getstring(x) ((x)->n_string)
- X#define getslength(x) ((x)->n_strlen)
- X
- X/* file stream access macros */
- X#define getfile(x) ((x)->n_fp)
- X#define setfile(x,v) ((x)->n_fp = (v))
- X#define getsavech(x) ((x)->n_savech)
- X#define setsavech(x,v) ((x)->n_savech = (v))
- X
- X/* unnamed stream access macros */
- X#define gethead(x) ((x)->n_car)
- X#define sethead(x,v) ((x)->n_car = (v))
- X#define gettail(x) ((x)->n_cdr)
- X#define settail(x,v) ((x)->n_cdr = (v))
- X
- X/* node types */
- X#define FREE 0
- X#define SUBR 1
- X#define FSUBR 2
- X#define CONS 3
- X#define SYMBOL 4
- X#define FIXNUM 5
- X#define FLONUM 6
- X#define STRING 7
- X#define OBJECT 8
- X#define STREAM 9
- X#define VECTOR 10
- X#define CLOSURE 11
- X#define CHAR 12
- X#define USTREAM 13
- X#define STRUCT 14
- X
- X/* Left the n_type definitions here rather */
- X/* than moving them to xwinterp.h and */
- X/* gobject.h because inadvertent collisions*/
- X/* would be a disaster. */
- X#ifdef PROVIDE_WINTERP
- X#define XLTYPE_XtAccelerators 15
- X#define XLTYPE_XtTranslations 16
- X#define XLTYPE_XtCallbackList 17
- X#define XLTYPE_XEvent 18
- X#define XLTYPE_Window 19
- X#define XLTYPE_Pixel 20
- X#define XLTYPE_Pixmap 21
- X#define XLTYPE_XImage 22
- X#define XLTYPE_XmString 23
- X#define XLTYPE_XmFontList 24
- X#define XLTYPE_caddr_t 25 /* generic pointer */
- X#define XLTYPE_XT_RESOURCE 26
- X#define XLTYPE_CALLBACKOBJ 27
- X#define XLTYPE_TIMEOUTOBJ 28
- X#define XLTYPE_PIXMAP_REFOBJ 29
- X#define XLTYPE_WIDGETOBJ 30
- X#define XLTYPE_EVHANDLEROBJ 31
- X#endif
- X#ifdef PROVIDE_XGBJ
- X/* Pick a number well away from the winterp progression, */
- X/* but not large enough to invite signed-char bugs: */
- X#define GOBJECT (97)
- X#endif
- X
- X
- X
- X/* subr/fsubr node */
- X#define n_subr n_info.n_xsubr.xs_subr
- X#define n_offset n_info.n_xsubr.xs_offset
- X
- X/* cons node */
- X#define n_car n_info.n_xcons.xc_car
- X#define n_cdr n_info.n_xcons.xc_cdr
- X
- X/* fixnum node */
- X#define n_fixnum n_info.n_xfixnum.xf_fixnum
- X
- X/* flonum node */
- X#define n_flonum n_info.n_xflonum.xf_flonum
- X/* character node */
- X#define n_chcode n_info.n_xchar.xc_chcode
- X
- X/* string node */
- X#define n_string n_info.n_xstring.xs_string
- X#define n_strlen n_info.n_xstring.xs_length
- X
- X/* stream node */
- X#define n_fp n_info.n_xstream.xs_fp
- X#define n_savech n_info.n_xstream.xs_savech
- X
- X/* vector/object node */
- X#define n_vsize n_info.n_xvector.xv_size
- X#define n_vdata n_info.n_xvector.xv_data
- X
- X/* node structure */
- Xtypedef struct node {
- X char n_type; /* type of node */
- X char n_flags; /* flag bits */
- X union ninfo { /* value */
- X
- X struct xsubr { /* subr/fsubr node */
- X struct node *(*xs_subr)(); /* function pointer */
- X int xs_offset; /* offset into funtab */
- X } n_xsubr;
- X struct xcons { /* cons node */
- X struct node *xc_car; /* the car pointer */
- X struct node *xc_cdr; /* the cdr pointer */
- X } n_xcons;
- X struct xfixnum { /* fixnum node */
- X FIXTYPE xf_fixnum; /* fixnum value */
- X } n_xfixnum;
- X struct xflonum { /* flonum node */
- X FLOTYPE xf_flonum; /* flonum value */
- X } n_xflonum;
- X struct xchar { /* character node */
- X int xc_chcode; /* character code */
- X } n_xchar;
- X struct xstring { /* string node */
- X int xs_length; /* string length */
- X unsigned char *xs_string; /* string pointer */
- X } n_xstring;
- X struct xstream { /* stream node */
- X FILE *xs_fp; /* the file pointer */
- X int xs_savech; /* lookahead character */
- X } n_xstream;
- X struct xvector { /* vector/object/symbol/structure node */
- X int xv_size; /* vector size */
- X struct node **xv_data; /* vector data */
- X } n_xvector;
- X/* Include hybrid-class functions: *//* JSP */
- X#define MODULE_XLDMEM_H_NINFO
- X#include "../../xmodules.h"
- X#undef MODULE_XLDMEM_H_NINFO
- X
- X } n_info;
- X} *LVAL;
- X
- X/* memory segment structure definition */
- Xtypedef struct segment {
- X int sg_size;
- X struct segment *sg_next;
- X struct node sg_nodes[1];
- X} SEGMENT;
- X
- X/* memory allocation functions */
- Xextern LVAL cons(); /* (cons x y) */
- Xextern LVAL cvsymbol(); /* convert a string to a symbol */
- Xextern LVAL cvstring(); /* convert a string */
- Xextern LVAL cvfile(); /* convert a FILE * to a file */
- Xextern LVAL cvsubr(); /* convert a function to a subr/fsubr */
- Xextern LVAL cvfixnum(); /* convert a fixnum */
- Xextern LVAL cvflonum(); /* convert a flonum */
- Xextern LVAL cvchar(); /* convert a character */
- X
- Xextern LVAL newstring(); /* create a new string */
- Xextern LVAL newvector(); /* create a new vector */
- Xextern LVAL newobject(); /* create a new object */
- Xextern LVAL newclosure(); /* create a new closure */
- Xextern LVAL newustream(); /* create a new unnamed stream */
- Xextern LVAL newstruct(); /* create a new structure */
- X
- Xextern LVAL s_self,k_new,k_isnew; /* Symbol SELF, keywords :ISNEW :NEW *//*JSP*/
- Xextern LVAL cls_class,cls_object; /* Class objects for CLASS and OBJECT*//*JSP*/
- X
- X/* Include hybrid-class functions: *//* JSP */
- X#define MODULE_XLDMEM_H_GLOBALS
- X#include "../../xmodules.h"
- X#undef MODULE_XLDMEM_H_GLOBALS
- X
- X
- X
- END_OF_FILE
- if test 9492 -ne `wc -c <'src/xlisp/xcore/c/xldmem.h'`; then
- echo shar: \"'src/xlisp/xcore/c/xldmem.h'\" unpacked with wrong size!
- fi
- # end of 'src/xlisp/xcore/c/xldmem.h'
- fi
- echo shar: End of archive 3 \(of 16\).
- cp /dev/null ark3isdone
- MISSING=""
- for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
- if test ! -f ark${I}isdone ; then
- MISSING="${MISSING} ${I}"
- fi
- done
- if test "${MISSING}" = "" ; then
- echo You have unpacked all 16 archives.
- rm -f ark[1-9]isdone ark[1-9][0-9]isdone
- else
- echo You still need to unpack the following archives:
- echo " " ${MISSING}
- fi
- ## End of shell archive.
- exit 0
-